home *** CD-ROM | disk | FTP | other *** search
/ Chip 2004 May / CMCD0504.ISO / Software / Freeware / Programare / dspack / DSPACK231.exe / {app} / src / DSPack / DSUtil.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2003-02-21  |  106.1 KB  |  2,609 lines
  1.  
  2.     (*********************************************************************
  3.      *  DSPack 2.3                                                       *
  4.      *                                                                   *
  5.      *  home page : http://www.progdigy.com                              *
  6.      *  email     : hgourvest@progdigy.com                               *
  7.      *   Thanks to Michael Andersen. (DSVideoWindowEx)                   *
  8.      *                                                                   *
  9.      *  date      : 21-02-2003                                           *
  10.      *                                                                   *
  11.      *  The contents of this file are used with permission, subject to   *
  12.      *  the Mozilla Public License Version 1.1 (the "License"); you may  *
  13.      *  not use this file except in compliance with the License. You may *
  14.      *  obtain a copy of the License at                                  *
  15.      *  http://www.mozilla.org/MPL/MPL-1.1.html                          *
  16.      *                                                                   *
  17.      *  Software distributed under the License is distributed on an      *
  18.      *  "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or   *
  19.      *  implied. See the License for the specific language governing     *
  20.      *  rights and limitations under the License.                        *
  21.      *                                                                   *
  22.      *********************************************************************)
  23.  
  24. {
  25.   @abstract(Methods & usefull Class for Direct Show programming.)
  26.   @author(Henri Gourvest: hgourvest@progdigy.com)
  27.   @created(Mar 14, 2002)
  28.   @lastmod(Feb 21, 2002)
  29. }
  30.  
  31. unit DSUtil;
  32. {$IFDEF VER150}
  33.   {$WARN UNSAFE_CODE OFF}
  34.   {$WARN UNSAFE_TYPE OFF}
  35.   {$WARN UNSAFE_CAST OFF}
  36. {$ENDIF}
  37.  
  38. interface
  39.  
  40. uses
  41. {$IFDEF VER140} Variants, {$ENDIF}
  42. {$IFDEF VER150} Variants, {$ENDIF}
  43. Windows, Controls, SysUtils, ActiveX, Classes, MMSystem, DirectShow9;
  44.  
  45.  
  46. const
  47.  
  48.   IID_IPropertyBag          : TGUID = '{55272A00-42CB-11CE-8135-00AA004BB851}';
  49.   IID_ISpecifyPropertyPages : TGUID = '{B196B28B-BAB4-101A-B69C-00AA00341D07}';
  50.   IID_IPersistStream        : TGUID = '{00000109-0000-0000-C000-000000000046}';
  51.   IID_IMoniker              : TGUID = '{0000000F-0000-0000-C000-000000000046}';
  52.  
  53.   // MS Mepg4 DMO
  54.   MEDIASUBTYPE_MP42         : TGUID = '{3234504D-0000-0010-8000-00AA00389B71}';
  55.   // DIVX
  56.   MEDIASUBTYPE_DIVX         : TGUID = '{58564944-0000-0010-8000-00AA00389B71}';
  57.   // VoxWare MetaSound
  58.   MEDIASUBTYPE_VOXWARE      : TGUID = '{00000075-0000-0010-8000-00AA00389B71}';
  59.  
  60.   MiliSecPerDay : Cardinal = 86400000;
  61.   MAX_TIME : Int64 = $7FFFFFFFFFFFFFFF;
  62.  
  63. ////////////////////////////////////////////////////////////////////////////////
  64. // DIVX ressources translated from latest OpenDivx DirectX Codec
  65.  
  66.   // divx
  67.   CLSID_DIVX    : TGUID = '{78766964-0000-0010-8000-00aa00389b71}';
  68.   // DIVX
  69.   CLSID_DivX_U  : TGUID = '{58564944-0000-0010-8000-00aa00389b71}';
  70.   // dvx1
  71.   CLSID_DivX_   : TGUID = '{31787664-0000-0010-8000-00aa00389b71}';
  72.   // DVX1
  73.   CLSID_DivX__U : TGUID = '{31585644-0000-0010-8000-00aa00389b71}';
  74.   // dx50
  75.   CLSID_dx50    : TGUID = '{30357864-0000-0010-8000-00aa00389b71}';
  76.   // DX50
  77.   CLSID_DX50_   : TGUID = '{30355844-0000-0010-8000-00aa00389b71}';
  78.   // div6
  79.   CLSID_div6    : TGUID = '{36766964-0000-0010-8000-00aa00389b71}';
  80.   // DIV6
  81.   CLSID_DIV6_   : TGUID = '{36564944-0000-0010-8000-00aa00389b71}';
  82.   // div5
  83.   CLSID_div5    : TGUID = '{35766964-0000-0010-8000-00aa00389b71}';
  84.   // DIV5
  85.   CLSID_DIV5_   : TGUID = '{35564944-0000-0010-8000-00aa00389b71}';
  86.   // div4
  87.   CLSID_div4    : TGUID = '{34766964-0000-0010-8000-00aa00389b71}';
  88.   // DIV4
  89.   CLSID_DIV4_   : TGUID = '{34564944-0000-0010-8000-00aa00389b71}';
  90.   // div3
  91.   CLSID_div3    : TGUID = '{33766964-0000-0010-8000-00aa00389b71}';
  92.   // DIV3
  93.   CLSID_DIV3_   : TGUID = '{33564944-0000-0010-8000-00aa00389b71}';
  94.  
  95.   CLSID_DIVXCodec           : TGUID = '{78766964-0000-0010-8000-00aa00389b71}';
  96.   IID_IIDivXFilterInterface : TGUID = '{D132EE97-3E38-4030-8B17-59163B30A1F5}';
  97.   CLSID_DivXPropertiesPage  : TGUID = '{310e42a0-f913-11d4-887c-006008dc5c26}';
  98.  
  99. type
  100.  
  101.   { Interface to control the Divx Decoder filter.
  102.     TODO: discover the last function ... }
  103.   IDivXFilterInterface = interface(IUnknown)
  104.     ['{D132EE97-3E38-4030-8B17-59163B30A1F5}']
  105.     { OpenDivx }
  106.     // current postprocessing level 0..100
  107.     function get_PPLevel(out PPLevel: integer): HRESULT; stdcall;
  108.     // new postprocessing level 0..100
  109.     function put_PPLevel(PPLevel: integer): HRESULT; stdcall;
  110.     // Put the default postprocessing = 0
  111.     function put_DefaultPPLevel: HRESULT; stdcall;
  112.     { DIVX }
  113.     function put_MaxDelayAllowed(maxdelayallowed: integer): HRESULT; stdcall;
  114.     function put_Brightness(brightness: integer): HRESULT; stdcall;
  115.     function put_Contrast(contrast: integer): HRESULT; stdcall;
  116.     function put_Saturation(saturation: integer): HRESULT; stdcall;
  117.     function get_MaxDelayAllowed(out maxdelayallowed: integer): HRESULT; stdcall;
  118.     function get_Brightness(out brightness: integer): HRESULT; stdcall;
  119.     function get_Contrast(out contrast: integer): HRESULT; stdcall;
  120.     function get_Saturation(out saturation: integer): HRESULT; stdcall;
  121.     function put_AspectRatio(x, y: integer): HRESULT; stdcall;
  122.     function get_AspectRatio(out x, y: integer): HRESULT; stdcall;
  123.   end;
  124.  
  125. ////////////////////////////////////////////////////////////////////////////////
  126. // Ogg Vorbis
  127.  
  128. type
  129.   TVORBISFORMAT = record
  130.     nChannels:        WORD;
  131.     nSamplesPerSec:   Longword;
  132.     nMinBitsPerSec:   Longword;
  133.     nAvgBitsPerSec:   Longword;
  134.     nMaxBitsPerSec:   Longword;
  135.     fQuality:         Double;
  136.   end;
  137.  
  138. const
  139.  
  140.   // f07e245f-5a1f-4d1e-8bff-dc31d84a55ab
  141.   CLSID_OggSplitter: TGUID = '{f07e245f-5a1f-4d1e-8bff-dc31d84a55ab}';
  142.  
  143.   // {078C3DAA-9E58-4d42-9E1C-7C8EE79539C5}
  144.   CLSID_OggSplitPropPage: TGUID = '{078C3DAA-9E58-4d42-9E1C-7C8EE79539C5}';
  145.  
  146.   // 8cae96b7-85b1-4605-b23c-17ff5262b296
  147.   CLSID_OggMux: TGUID = '{8cae96b7-85b1-4605-b23c-17ff5262b296}';
  148.  
  149.   // {AB97AFC3-D08E-4e2d-98E0-AEE6D4634BA4}
  150.   CLSID_OggMuxPropPage: TGUID = '{AB97AFC3-D08E-4e2d-98E0-AEE6D4634BA4}';
  151.  
  152.   // {889EF574-0656-4B52-9091-072E52BB1B80}
  153.   CLSID_VorbisEnc: TGUID = '{889EF574-0656-4B52-9091-072E52BB1B80}';
  154.  
  155.   // {c5379125-fd36-4277-a7cd-fab469ef3a2f}
  156.   CLSID_VorbisEncPropPage: TGUID = '{c5379125-fd36-4277-a7cd-fab469ef3a2f}';
  157.  
  158.   // 02391f44-2767-4e6a-a484-9b47b506f3a4
  159.   CLSID_VorbisDec: TGUID = '{02391f44-2767-4e6a-a484-9b47b506f3a4}';
  160.  
  161.   // 77983549-ffda-4a88-b48f-b924e8d1f01c
  162.   CLSID_OggDSAboutPage: TGUID = '{77983549-ffda-4a88-b48f-b924e8d1f01c}';
  163.  
  164.   // {D2855FA9-61A7-4db0-B979-71F297C17A04}
  165.   MEDIASUBTYPE_Ogg: TGUID = '{D2855FA9-61A7-4db0-B979-71F297C17A04}';
  166.  
  167.   // cddca2d5-6d75-4f98-840e-737bedd5c63b
  168.   MEDIASUBTYPE_Vorbis: TGUID = '{cddca2d5-6d75-4f98-840e-737bedd5c63b}';
  169.  
  170.   // 6bddfa7e-9f22-46a9-ab5e-884eff294d9f
  171.   FORMAT_VorbisFormat: TGUID = '{6bddfa7e-9f22-46a9-ab5e-884eff294d9f}';
  172.  
  173.  
  174. ////////////////////////////////////////////////////////////////////////////////
  175. // WMF9 Utils
  176. type
  177.   TWMPofiles8 = (
  178.     wmp_V80_255VideoPDA,
  179.     wmp_V80_150VideoPDA,
  180.     wmp_V80_28856VideoMBR,
  181.     wmp_V80_100768VideoMBR,
  182.     wmp_V80_288100VideoMBR,
  183.     wmp_V80_288Video,
  184.     wmp_V80_56Video,
  185.     wmp_V80_100Video,
  186.     wmp_V80_256Video,
  187.     wmp_V80_384Video,
  188.     wmp_V80_768Video,
  189.     wmp_V80_700NTSCVideo,
  190.     wmp_V80_1400NTSCVideo,
  191.     wmp_V80_384PALVideo,
  192.     wmp_V80_700PALVideo,
  193.     wmp_V80_288MonoAudio,
  194.     wmp_V80_288StereoAudio,
  195.     wmp_V80_32StereoAudio,
  196.     wmp_V80_48StereoAudio,
  197.     wmp_V80_64StereoAudio,
  198.     wmp_V80_96StereoAudio,
  199.     wmp_V80_128StereoAudio,
  200.     wmp_V80_288VideoOnly,
  201.     wmp_V80_56VideoOnly,
  202.     wmp_V80_FAIRVBRVideo,
  203.     wmp_V80_HIGHVBRVideo,
  204.     wmp_V80_BESTVBRVideo
  205.   );
  206.  
  207. const
  208.    WMProfiles8 : array[TWMPofiles8] of TGUID =
  209.     ('{FEEDBCDF-3FAC-4c93-AC0D-47941EC72C0B}',
  210.      '{AEE16DFA-2C14-4a2f-AD3F-A3034031784F}',
  211.      '{D66920C4-C21F-4ec8-A0B4-95CF2BD57FC4}',
  212.      '{5BDB5A0E-979E-47d3-9596-73B386392A55}',
  213.      '{D8722C69-2419-4b36-B4E0-6E17B60564E5}',
  214.      '{3DF678D9-1352-4186-BBF8-74F0C19B6AE2}',
  215.      '{254E8A96-2612-405c-8039-F0BF725CED7D}',
  216.      '{A2E300B4-C2D4-4fc0-B5DD-ECBD948DC0DF}',
  217.      '{BBC75500-33D2-4466-B86B-122B201CC9AE}',
  218.      '{29B00C2B-09A9-48bd-AD09-CDAE117D1DA7}',
  219.      '{74D01102-E71A-4820-8F0D-13D2EC1E4872}',
  220.      '{C8C2985F-E5D9-4538-9E23-9B21BF78F745}',
  221.      '{931D1BEE-617A-4bcd-9905-CCD0786683EE}',
  222.      '{9227C692-AE62-4f72-A7EA-736062D0E21E}',
  223.      '{EC298949-639B-45e2-96FD-4AB32D5919C2}',
  224.      '{7EA3126D-E1BA-4716-89AF-F65CEE0C0C67}',
  225.      '{7E4CAB5C-35DC-45bb-A7C0-19B28070D0CC}',
  226.      '{60907F9F-B352-47e5-B210-0EF1F47E9F9D}',
  227.      '{5EE06BE5-492B-480a-8A8F-12F373ECF9D4}',
  228.      '{09BB5BC4-3176-457f-8DD6-3CD919123E2D}',
  229.      '{1FC81930-61F2-436f-9D33-349F2A1C0F10}',
  230.      '{407B9450-8BDC-4ee5-88B8-6F527BD941F2}',
  231.      '{8C45B4C7-4AEB-4f78-A5EC-88420B9DADEF}',
  232.      '{6E2A6955-81DF-4943-BA50-68A986A708F6}',
  233.      '{3510A862-5850-4886-835F-D78EC6A64042}',
  234.      '{0F10D9D3-3B04-4fb0-A3D3-88D4AC854ACC}',
  235.      '{048439BA-309C-440e-9CB4-3DCCA3756423}');
  236.  
  237.  
  238.   function ProfileFromGUID(const GUID: TGUID): TWMPofiles8;
  239. ////////////////////////////////////////////////////////////////////////////////
  240.  
  241.   { Frees an object reference and replaces the reference with Nil. (Delphi4 compatibility)}
  242.   procedure FreeAndNil(var Obj);
  243.  
  244.   { Enable Graphedit to connect with a filter graph.<br>
  245.     The application must register the filter graph instance in the Running Object
  246.     Table (ROT). The ROT is a globally accessible look-up table that keeps track
  247.     of running objects. Objects are registered in the ROT by moniker. To connect
  248.     to the graph, GraphEdit searches the ROT for monikers whose display name matches
  249.     a particular format: !FilterGraph X pid Y.<br>
  250.     <b>Graph:</b> a graph interface (IGraphBuilder, IFilterGraph, IFilterGraph2).<br>
  251.     <b>ID:</b> return the ROT identifier.}
  252.   function AddGraphToRot(Graph: IFilterGraph; out ID: integer): HRESULT;
  253.  
  254.   { Disable Graphedit to connect with your filter graph.<br>
  255.     <b>ID:</b> identifier provided by the @link(AddGraphToRot) method.}
  256.   function RemoveGraphFromRot(ID: integer): HRESULT;
  257.  
  258.   { deprecated, convert a Time code event to TDVD_TimeCode record. }
  259.   function IntToTimeCode(x : longint): TDVDTimeCode;
  260.  
  261.   { Return a string explaining a filter graph event. }
  262.   function  GetEventCodeDef(code: longint): string;
  263.  
  264.   { General purpose function to delete a heap allocated TAM_MEDIA_TYPE structure
  265.     which is useful when calling IEnumMediaTypes.Next as the interface
  266.     implementation allocates the structures which you must later delete
  267.     the format block may also be a pointer to an interface to release. }
  268.   procedure DeleteMediaType(pmt: PAMMediaType);
  269.  
  270.   { The CreateMediaType function allocates a new AM_MEDIA_TYPE structure,
  271.     including the format block. This also comes in useful when using the
  272.     IEnumMediaTypes interface so that you can copy a media type, you can do
  273.     nearly the same by creating a TMediaType class but as soon as it goes out
  274.     of scope the destructor will delete the memory it allocated
  275.     (this takes a copy of the memory). }
  276.   function  CreateMediaType(pSrc: PAMMediaType): PAMMediaType;
  277.  
  278.   { The CopyMediaType function copies an AM_MEDIA_TYPE structure into another
  279.     structure, including the format block. This function allocates the memory
  280.     for the format block. If the pmtTarget parameter already contains an allocated
  281.     format block, a memory leak will occur. To avoid a memory leak, call
  282.     FreeMediaType before calling this function. }
  283.   procedure CopyMediaType(pmtTarget: PAMMediaType; pmtSource: PAMMediaType);
  284.  
  285.   { The FreeMediaType function frees the format block in an AM_MEDIA_TYPE structure.
  286.     Use this function to free just the format block. To delete the AM_MEDIA_TYPE
  287.     structure, call DeleteMediaType. }
  288.   procedure FreeMediaType(mt: PAMMediaType);
  289.  
  290.   { The CreateAudioMediaType function initializes a media type from a TWAVEFORMATEX structure.
  291.     If the bSetFormat parameter is TRUE, the method allocates the memory for the format
  292.     block. If the pmt parameter already contains an allocated format block, a memory
  293.     leak will occur. To avoid a memory leak, call FreeMediaType before calling this function.
  294.     After the method returns, call FreeMediaType again to free the format block. }
  295.   function CreateAudioMediaType(pwfx: PWaveFormatEx; pmt: PAMMediaType; bSetFormat: boolean): HRESULT;
  296.  
  297.   { The FOURCCMap function provides conversion between GUID media subtypes and
  298.     old-style FOURCC 32-bit media tags. In the original Microsoft« Windows«
  299.     multimedia APIs, media types were tagged with 32-bit values created from
  300.     four 8-bit characters and were known as FOURCCs. Microsoft DirectShow« media
  301.     types have GUIDs for the subtype, partly because these are simpler to create
  302.     (creation of a new FOURCC requires its registration with Microsoft).
  303.     Because FOURCCs are unique, a one-to-one mapping has been made possible by
  304.     allocating a range of 4,000 million GUIDs representing FOURCCs. This range
  305.     is all GUIDs of the form: XXXXXXXX-0000-0010-8000-00AA00389B71. }
  306.   function FOURCCMap(Fourcc: Cardinal): TGUID;
  307.  
  308.   { Find the four-character codes wich identifi a codec. }
  309.   function GetFOURCC(Fourcc: Cardinal): string;
  310.  
  311.   { Convert a FCC (Four Char Codes) to Cardinal. A FCC identifie a media type.}
  312.   function FCC(str: String): Cardinal;
  313.  
  314.   { Create the four-character codes from a Cardinal value. }
  315.   function MAKEFOURCC(ch0, ch1, ch2, ch3: char): Cardinal;
  316.  
  317.   { The GetErrorString function retrieves the error message for a given return
  318.     code, using the current language setting.}
  319.   function GetErrorString(hr: HRESULT): string;
  320.  
  321.   { This function examine a media type and return a short description like GraphEdit. }
  322.   function GetMediaTypeDescription(MediaType: TAMMediaType): string;
  323.  
  324.   { Retrieve the Size needed to store a bitmat }
  325.   function GetBitmapSize(const pHeader: TBITMAPINFOHEADER): DWORD;
  326.  
  327. type
  328.   { Property pages.<br>See also: @link(ShowFilterPropertyPage), @link:(HaveFilterPropertyPage).}
  329.   TPropertyPage = (
  330.     ppDefault,       // Simple property page.
  331.     ppVFWCapDisplay, // Capture Video source dialog box.
  332.     ppVFWCapFormat,  // Capture Video format dialog box.
  333.     ppVFWCapSource,  // Capture Video source dialog box.
  334.     ppVFWCompConfig, // Compress Configure dialog box.
  335.     ppVFWCompAbout   // Compress About Dialog box.
  336.   );
  337.  
  338.   { Show the property page associated with the Filter.
  339.     A property page is one way for a filter to support properties that the user can set.
  340.     Many of the filters provided with DirectShow support property pages, they are
  341.     intended for debugging purposes, and are not recommended for application use.
  342.     In most cases the equivalent functionality is provided through a custom interface
  343.     on the filter. An application should control these filters programatically,
  344.     rather than expose their property pages to users. }
  345.   function ShowFilterPropertyPage(parent: THandle; Filter: IBaseFilter;
  346.     PropertyPage: TPropertyPage = ppDefault): HRESULT;
  347.  
  348.   { Return true if the specified property page is provided by the Filter.}
  349.   function HaveFilterPropertyPage(Filter: IBaseFilter;
  350.     PropertyPage: TPropertyPage = ppDefault): boolean;
  351.  
  352.   { Show the property page associated with the Pin. <br>
  353.     <b>See also: </b> @link:(ShowFilterPropertyPage).}
  354.   function ShowPinPropertyPage(parent: THandle; Pin: IPin): HRESULT;
  355.  
  356.   { Convert 100 nano sec unit to milisecondes. }
  357.   function RefTimeToMiliSec(RefTime: Int64): Cardinal;
  358.  
  359.   { Convert milisecondes to 100 nano sec unit}
  360.   function MiliSecToRefTime(Milisec: int64): Int64;
  361.  
  362. {  The mechanism for describing a bitmap format is with the BITMAPINFOHEADER
  363.    This is really messy to deal with because it invariably has fields that
  364.    follow it holding bit fields, palettes and the rest. This function gives
  365.    the number of bytes required to hold a VIDEOINFO that represents it. This
  366.    count includes the prefix information (like the rcSource rectangle) the
  367.    BITMAPINFOHEADER field, and any other colour information on the end.
  368.  
  369.    WARNING If you want to copy a BITMAPINFOHEADER into a VIDEOINFO always make
  370.    sure that you use the HEADER macro because the BITMAPINFOHEADER field isn't
  371.    right at the start of the VIDEOINFO (there are a number of other fields),
  372.  
  373.        CopyMemory(HEADER(pVideoInfo),pbmi,sizeof(BITMAPINFOHEADER)); }
  374.   function GetBitmapFormatSize(const Header: TBitmapInfoHeader): Integer;
  375.  
  376.   { Retrieve original source rectangle from a TAM_Media_type record.}
  377.   function GetSourceRectFromMediaType(const MediaType: TAMMediaType): TRect;
  378.  
  379.   { TODO -oMichael Andersen: make documentation }
  380.   function StretchRect(R, IR: TRect): TRect;
  381.  
  382.   // raise @link(EDirectShowException) exception if failed.
  383.   function CheckDSError(HR: HRESULT): HRESULT;
  384.  
  385. type
  386.   // DirectShow Exception class
  387.   EDirectShowException = class(Exception)
  388.     ErrorCode: Integer;
  389.   end;
  390.  
  391.   EDSPackException = class(Exception)
  392.     ErrorCode: Integer;
  393.   end;
  394.  
  395. // *****************************************************************************
  396. //  TSysDevEnum
  397. // *****************************************************************************
  398.   {@exclude}
  399.   PFilCatNode = ^TFilCatNode;
  400.   {@exclude}
  401.   TFilCatNode = record
  402.     FriendlyName : Shortstring;
  403.     CLSID        : TGUID;
  404.   end;
  405.  
  406.   { Usefull class to enumerate availables filters.
  407.     See "Filter Enumerator" sample. }
  408.   TSysDevEnum = class
  409.   private
  410.     FGUID       : TGUID;
  411.     FCategories : TList;
  412.     FFilters    : TList;
  413.     ACategory   : PFilCatNode;
  414.     procedure   GetCat(catlist: TList; CatGUID: TGUID);
  415.     function    GetCountCategories: integer;
  416.     function    GetCountFilters: integer;
  417.     function    GetCategory(item: integer): TFilCatNode;
  418.     function    GetFilter(item: integer): TFilCatNode;
  419.   public
  420.     { Select the main category by GUID. For example CLSID_VideoCompressorCategory
  421.       to enumerate Video Compressors. }
  422.     procedure SelectGUIDCategory(GUID: TGUID);
  423.     { Select the main category by Index. }
  424.     procedure SelectIndexCategory(index: integer);
  425.     { Call CountCategories to retrieve categories count.}
  426.     property CountCategories: integer read GetCountCategories;
  427.     { Call CountFilters to retrieve the number of Filte within a Category. }
  428.     property CountFilters: integer read GetCountFilters;
  429.     { Call Categories to read Category Name and GUID. }
  430.     property Categories[item: integer]: TFilCatNode read GetCategory;
  431.     { Call Filters to read Filter Name and GUID. }
  432.     property Filters[item: integer]: TFilCatNode read GetFilter;
  433.     { Call GetBaseFilter to retrieve the IBaseFilter interface corresponding to index. }
  434.     function GetBaseFilter(index: integer): IBaseFilter; overload;
  435.     { Call GetBaseFilter to retrieve the IBaseFilter interface corresponding to GUID. }
  436.     function GetBaseFilter(GUID: TGUID): IBaseFilter; overload;
  437.     { Call GetMoniker to retrieve the IMoniker interface corresponding to index.
  438.       This interface can be used to store a filter with the @link(TBaseFiter) class. }
  439.     function GetMoniker(index: integer): IMoniker;
  440.     { constructor }
  441.     Constructor Create; overload;
  442.     { constructor. Create the class and initialize the main category with the GUID. }
  443.     constructor Create(guid: TGUID); overload;
  444.     { destructor }
  445.     destructor Destroy; override;
  446.   end;
  447.  
  448. // *****************************************************************************
  449. //  TFilterList
  450. // *****************************************************************************
  451.  
  452.   { This class can enumerate all filters in a FilterGraph. }
  453.   TFilterList = class(TInterfaceList)
  454.   private
  455.     Graph : IFilterGraph;
  456.     function  GetFilter(Index: Integer): IBaseFilter;
  457.     procedure PutFilter(Index: Integer; Item: IBaseFilter);
  458.     function  GetFilterInfo(index: integer): TFilterInfo;
  459.   public
  460.     { Create a list based on a FilterGraph. }
  461.     constructor Create(FilterGraph: IFilterGraph); overload;
  462.     { Destructor. }
  463.     destructor Destroy; override;
  464.     { Update the list. }
  465.     procedure Update;
  466.     { Reload the list from another FilterGraph.}
  467.     procedure Assign(FilterGraph: IFilterGraph);
  468.     { Call First to obtain the first interface in the list. }
  469.     function First: IBaseFilter;
  470.     { Call IndexOf to obtain the index of an interface. }
  471.     function IndexOf(Item: IBaseFilter): Integer;
  472.     { Call Add to add an interface to the list. }
  473.     function Add(Item: IBaseFilter): Integer;
  474.     { Call Insert to insert an interface into the list. Item is the interface to
  475.       insert, and Index indicates the position (zero-offset) where the interface
  476.       should be added. }
  477.     procedure Insert(Index: Integer; Item: IBaseFilter);
  478.     { Call Last to obtain the last interface in the list. }
  479.     function Last: IBaseFilter;
  480.     { Call Remove to remove an interface from the list. Remove returns the index
  481.       of the removed interface, or û1 if the interface was not found. }
  482.     function Remove(Item: IBaseFilter): Integer;
  483.     { Use Items to directly access an interface in the list. Index identifies each
  484.       interface by its position in the list. }
  485.     property Items[Index: Integer]: IBaseFilter read GetFilter write PutFilter; default;
  486.     { call FilterInfo to retrieve the Filer name and his FilterGraph. }
  487.     property FilterInfo[Index: Integer] : TFilterInfo read GetFilterInfo;
  488.   end;
  489.  
  490. //******************************************************************************
  491. //  TPinList
  492. //******************************************************************************
  493.  
  494.   {Helper class to enumerate pins on a filter. }
  495.   TPinList = class(TInterfaceList)
  496.   private
  497.     Filter: IBaseFilter;
  498.     function  GetPin(Index: Integer): IPin;
  499.     procedure PutPin(Index: Integer; Item: IPin);
  500.     function  GetPinInfo(index: integer): TPinInfo;
  501.     function GetConnected(Index: Integer): boolean;
  502.   public
  503.     { Create a Pin list from the IBaseFilter interface. }
  504.     constructor Create(BaseFilter: IBaseFilter); overload;
  505.     { Destructor. }
  506.     destructor Destroy; override;
  507.     { Update the Pin list. }
  508.     procedure Update;
  509.     { Load a Pin list from the IBaseFilter Interface. }
  510.     procedure Assign(BaseFilter: IBaseFilter);
  511.     { Return the First Pin from in the list. }
  512.     function First: IPin;
  513.     { Return the index of Pin in the list. }
  514.     function IndexOf(Item: IPin): Integer;
  515.     { Add A Pin to the list. }
  516.     function Add(Item: IPin): Integer;
  517.     { Insert a pin at the given position. }
  518.     procedure Insert(Index: Integer; Item: IPin);
  519.     { Return the last pin in the list. }
  520.     function Last: IPin;
  521.     { Remove a pin from the lis. }
  522.     function Remove(Item: IPin): Integer;
  523.     { Return the the pin interface at the defined position. }
  524.     property Items[Index: Integer]: IPin read GetPin write PutPin; default;
  525.     { Retrieve informations on a pin. }
  526.     property PinInfo[Index: Integer]: TPinInfo read GetPinInfo;
  527.     property Connected[Index: Integer]: boolean read GetConnected;
  528.   end;
  529.  
  530. // *****************************************************************************
  531. //  TMediaType
  532. // *****************************************************************************
  533.  
  534.   { Uses TMediaType to configure media types. This class have a special property editor.
  535.     See @link(TSampleGrabber)}
  536.   TMediaType = class(TPersistent)
  537.   private
  538.     function GetMajorType: TGUID;
  539.     procedure SetMajorType(MT: TGUID);
  540.     function GetSubType: TGUID;
  541.     procedure SetSubType(ST: TGUID);
  542.     procedure SetFormatType(const GUID: TGUID);
  543.     function GetFormatType: TGUID;
  544.     procedure ReadData(Stream: TStream);
  545.     procedure WriteData(Stream: TStream);
  546.   protected
  547.     { @exclude}
  548.     procedure DefineProperties(Filer: TFiler); override;
  549.   public
  550.     { Local copy of the Media Type. }
  551.     AMMediaType: PAMMediaType;
  552.     { Destructor method. }
  553.     destructor Destroy; override;
  554.     { Constructor method. }
  555.     constructor Create; overload;
  556.     { Constructor method. Initialised with majortype. }
  557.     constructor Create(majortype: TGUID); overload;
  558.     { Constructor method. Initialised with another media type. }
  559.     constructor Create(mediatype: PAMMediaType); overload;
  560.     { Constructor method. Initialised with another TMediaType}
  561.     constructor Create(MTClass: TMediaType); overload;
  562.     { Copy from another TMediaType. }
  563.     procedure Assign(Source: TPersistent); override;
  564.     { Copy from another PAM_MEDIA_TYPE. }
  565.     procedure Read(mediatype: PAMMediaType);
  566.     { Tests for equality between TMediaType objects.<br>
  567.       <b>rt:</b> Reference to the TMediaType object to compare.<br>
  568.       Returns TRUE if rt is equal to this object. Otherwise, returns FALSE. }
  569.     function Equal(MTClass: TMediaType): boolean; overload;
  570.     { Tests for inequality between TMediaType objects.<br>
  571.       <b>rt:</b> Reference to the TMediaType object to compare.<br>
  572.       Returns TRUE if rt is not equal to this object. Otherwise, returns FALSE. }
  573.     function NotEqual(MTClass: TMediaType): boolean; overload;
  574.     { The IsValid method determines whether a major type has been assigned to this object.
  575.       Returns TRUE if a major type has been assigned to this object. Otherwise, returns FALSE.
  576.       By default, TMediaType objects are initialized with a major type of GUID_NULL.
  577.       Call this method to determine whether the object has been correctly initialized.}
  578.     function IsValid: boolean;
  579.     { The IsFixedSize method determines if the samples have a fixed size or a variable size.
  580.       Returns the value of the bFixedSizeSamples member.}
  581.     function IsFixedSize: boolean;
  582.     { The IsTemporalCompressed method determines if the stream uses temporal compression.
  583.       Returns the value of the bTemporalCompression member. }
  584.     function IsTemporalCompressed: boolean;
  585.     { The GetSampleSize method retrieves the sample size.
  586.       If the sample size is fixed, returns the sample size in bytes. Otherwise,
  587.       returns zero. }
  588.     function GetSampleSize: ULONG;
  589.     { The SetSampleSize method specifies a fixed sample size, or specifies that
  590.       samples have a variable size. If value of sz is zero, the media type uses
  591.       variable sample sizes. Otherwise, the sample size is fixed at sz bytes. }
  592.     procedure SetSampleSize(SZ: ULONG);
  593.     { The SetVariableSize method specifies that samples do not have a fixed size.
  594.       This method sets the bFixedSizeSamples member to FALSE. Subsequent calls to the TMediaType.GetSampleSize method return zero. }
  595.     procedure SetVariableSize;
  596.     { The SetTemporalCompression method specifies whether samples are compressed
  597.       using temporal (interframe) compression. }
  598.     procedure SetTemporalCompression(bCompressed: boolean);
  599.     { read/write pointer to format - can't change length without
  600.       calling SetFormat, AllocFormatBuffer or ReallocFormatBuffer}
  601.     function Format: pointer;
  602.     { The FormatLength method retrieves the length of the format block. }
  603.     function FormatLength: ULONG;
  604.     { The SetFormat method specifies the format block.<br>
  605.       <b>pFormat:</b> Pointer to a block of memory that contains the format block.<br>
  606.       <b>length:</b> Length of the format block, in bytes. }
  607.     function SetFormat(pFormat: pointer; length: ULONG): boolean;
  608.     { The ResetFormatBuffer method deletes the format block. }
  609.     procedure ResetFormatBuffer;
  610.     { The AllocFormatBuffer method allocates memory for the format block.<br>
  611.       <b>length:</b> Size required for the format block, in bytes.<br>
  612.       Returns a pointer to the new block if successful. Otherwise, returns nil.<br>
  613.       If the method successfully allocates a new format block, it frees the existing
  614.       format block. If the allocation fails, the method leaves the existing format block. }
  615.     function AllocFormatBuffer(length: ULONG): pointer;
  616.     { The ReallocFormatBuffer method reallocates the format block to a new size.<br>
  617.       <b>length:</b> New size required for the format block, in bytes. Must be greater
  618.       than zero.<br>
  619.       Returns a pointer to the new block if successful. Otherwise, returns either
  620.       a pointer to the old format block, or nil.
  621.       This method allocates a new format block. It copies as much of the existing
  622.       format block as possible into the new format block. If the new block is
  623.       smaller than the existing block, the existing format block is truncated.
  624.       If the new block is larger, the contents of the additional space are undefined.
  625.       They are not explicitly set to zero. }
  626.     function ReallocFormatBuffer(length: ULONG): pointer;
  627.     { The InitMediaType method initializes the media type.
  628.       This method zeroes the object's memory, sets the fixed-sample-size property
  629.       to TRUE, and sets the sample size to 1. }
  630.     procedure InitMediaType;
  631.     { The MatchesPartial method determines if this media type matches a partially
  632.       specified media type. The media type specified by ppartial can have a value
  633.       of GUID_NULL for the major type, subtype, or format type. Any members with
  634.       GUID_NULL values are not tested. (In effect, GUID_NULL acts as a wildcard.)
  635.       Members with values other than GUID_NULL must match for the media type to match.}
  636.     function MatchesPartial(ppartial: TMediaType): boolean;
  637.     { The IsPartiallySpecified method determines if the media type is partially
  638.       defined. A media type is partial if the major type, subtype, or format type
  639.       is GUID_NULL. The IPin.Connect method can accept partial media types.
  640.       The implementation does not actually test the subtype. If there is a specified
  641.       format type, the media type is not considered partial, even if the subtype is GUID_NULL. }
  642.     function IsPartiallySpecified: boolean;
  643.     { Set or retrieve the MajorType GUID. }
  644.     property MajorType: TGUID read GetMajorType write SetMajorType;
  645.     { Set or retrieve the SubType GUID. }
  646.     property SubType: TGUID read GetSubType write SetSubType;
  647.     { Set or retrieve the FormatType GUID. }
  648.     property FormatType: TGUID read GetFormatType write SetFormatType;
  649.   end;
  650.  
  651. // *****************************************************************************
  652. //  TEnumMediaType
  653. // *****************************************************************************
  654.  
  655.   { This class can retrieve all media types from a pin, a file or an IEnumMediaTypes interface. }
  656.   TEnumMediaType = class(TObject)
  657.   private
  658.     FList      : TList;
  659.     function   GetItem(Index: Integer): TMediaType;
  660.     procedure  SetItem(Index: Integer; Item: TMediaType);
  661.     function   GetMediaDescription(Index: Integer): string;
  662.     function   GetCount: integer;
  663.   public
  664.     { Constructor method.}
  665.     constructor Create; overload;
  666.     { Constructor method enumerating all media types on a pin. }
  667.     constructor Create(Pin: IPin); overload;
  668.     { Constructor method enumerating media types provided by a IEnumMediaType interface. }
  669.     constructor Create(EnumMT: IEnumMediaTypes); overload;
  670.     { Constructor method enumerating all media types availables in a media file.
  671.       Support WMF files. }
  672.     constructor Create(FileName: TFileName); overload;
  673.     { Destructor method. }
  674.     destructor  Destroy; override;
  675.     { Enumerate all media types on a pin.}
  676.     procedure   Assign(Pin: IPin); overload;
  677.     { Enumerate media types provided by a IEnumMediaType interface. }
  678.     procedure   Assign(EnumMT: IEnumMediaTypes); overload;
  679.     { Enumerate all media types availables in a media file. Support WMF files. }
  680.     procedure   Assign(FileName: TFileName); overload;
  681.     { Add a media type to the list. }
  682.     function    Add(Item: TMediaType): Integer;
  683.     { Clear the list. }
  684.     procedure   Clear;
  685.     { Remove a media type from the list. }
  686.     procedure   Delete(Index: Integer);
  687.     { Retrieve a mediaa type. }
  688.     property    Items[Index: Integer]: TMediaType read GetItem write SetItem;
  689.     { Return a string describing the media type. }
  690.     property    MediaDescription[Index: Integer]: string read GetMediaDescription;
  691.     { Number of items in the list. }
  692.     property    Count: integer read GetCount;
  693.   end;
  694.  
  695. // *****************************************************************************
  696. //  TPersistentMemory
  697. // *****************************************************************************
  698.  
  699.   { For internal use. This class is designed to store a custom memory stream with
  700.     a form. It is the ancestor of @link(TBaseFilter).}
  701.   TPersistentMemory = class(TPersistent)
  702.     private
  703.       FData: pointer;
  704.       FDataLength: Cardinal;
  705.       procedure ReadData(Stream: TStream);
  706.       procedure WriteData(Stream: TStream);
  707.       function Equal(Memory: TPersistentMemory): boolean;
  708.       procedure AllocateMemory(ALength: Cardinal);
  709.     protected
  710.       { @exclude }
  711.       procedure AssignTo(Dest: TPersistent); override;
  712.       { @exclude }
  713.       procedure DefineProperties(Filer: TFiler); override;
  714.     public
  715.       { Set/Get the buffer length. }
  716.       property DataLength: Cardinal read FDataLength write AllocateMemory;
  717.       { Pointer to buffer. }
  718.       property Data: Pointer read FData;
  719.       { Constructor }
  720.       constructor Create; virtual;
  721.       { Destructor }
  722.       destructor Destroy; override;
  723.       { Call Assign to copy the properties or other attributes of one object from another. }
  724.       procedure Assign(Source: TPersistent); override;
  725.   end;
  726.  
  727. // *****************************************************************************
  728. //  TBaseFilter
  729. // *****************************************************************************
  730.  
  731.   { This class can store a custom filter as a moniker within the dfm file. }
  732.   TBaseFilter = class(TPersistentMemory)
  733.   private
  734.     procedure SetMoniker(Moniker: IMoniker);
  735.     function GetMoniker: IMoniker;
  736.   public
  737.     { Set or retrieve the moniker interface.}
  738.     property Moniker: IMoniker read GetMoniker write SetMoniker;
  739.     { Read a property bag. For example you can read the GUID identifier (PropertyBag('CLSID'))}
  740.     function PropertyBag(Name: WideString): OleVariant;
  741.     {Return the IBaseFilter interface corresponding to filter.}
  742.     function CreateFilter: IBaseFilter;
  743.   end;
  744.  
  745. {$IFDEF VER130}
  746.   procedure Set8087CW(NewCW: Word);
  747.   function Get8087CW: Word;
  748. {$ENDIF}
  749.  
  750. implementation
  751. uses DirectSound, math, ComObj;
  752. {$IFDEF VER130}
  753. var
  754.   Default8087CW: Word = $1372;
  755.  
  756.   procedure Set8087CW(NewCW: Word);
  757.   begin
  758.     Default8087CW := NewCW;
  759.     asm
  760.       FNCLEX
  761.       FLDCW Default8087CW
  762.     end;
  763.   end;
  764.  
  765.   function Get8087CW: Word;
  766.   asm
  767.     PUSH   0
  768.     FNSTCW [ESP].Word
  769.     POP    EAX
  770.   end;
  771. {$ENDIF}
  772.  
  773.   function ProfileFromGUID(const GUID: TGUID): TWMPofiles8;
  774.   begin
  775.     for result := low(TWMPofiles8) to high(TWMPofiles8) do
  776.       if IsEqualGUID(GUID, WMProfiles8[result]) then Exit;
  777.     Result := TWMPofiles8(-1);
  778.   end;
  779.  
  780.  //----------------------------------------------------------------------------
  781.  // Retrieve the Size needed to store a bitmat
  782.  //----------------------------------------------------------------------------
  783.   function GetBitmapSize(const pHeader: TBITMAPINFOHEADER): DWORD;
  784.     function WIDTHBYTES(bits: DWORD): DWORD;
  785.       begin result := DWORD((bits+31) and (not 31)) div 8; end;
  786.     function DIBWIDTHBYTES(bi: TBITMAPINFOHEADER): DWORD;
  787.       begin result := DWORD(WIDTHBYTES(DWORD(bi.biWidth) * DWORD(bi.biBitCount))); end;
  788.     function _DIBSIZE(bi: TBITMAPINFOHEADER): DWORD;
  789.       begin result := DIBWIDTHBYTES(bi) * DWORD(bi.biHeight); end;
  790.   begin
  791.     if (pHeader.biHeight < 0) then result := -1 * _DIBSIZE(pHeader)
  792.     else result := _DIBSIZE(pHeader);
  793.   end;
  794.  
  795.  //----------------------------------------------------------------------------
  796.  // Frees an object reference and replaces the reference with Nil.
  797.  //----------------------------------------------------------------------------
  798.   procedure FreeAndNil(var Obj);
  799.   var
  800.     Temp: TObject;
  801.   begin
  802.     Temp := TObject(Obj);
  803.     Pointer(Obj) := nil;
  804.     Temp.Free;
  805.   end;
  806.  
  807.   //----------------------------------------------------------------------------
  808.   // Enable Graphedit to connect with your filter graph
  809.   //----------------------------------------------------------------------------
  810.   function AddGraphToRot(Graph: IFilterGraph; out ID: integer): HRESULT;
  811.   var
  812.     Moniker: IMoniker;
  813.     ROT    : IRunningObjectTable;
  814.     wsz    : WideString;
  815.   begin
  816.     result := GetRunningObjectTable(0, ROT);
  817.     if (result <> S_OK) then exit;
  818.     wsz := format('FilterGraph %p pid %x',[pointer(graph),GetCurrentProcessId()]);
  819.     result  := CreateItemMoniker('!', PWideChar(wsz), Moniker);
  820.     if (result <> S_OK) then exit;
  821.     result  := ROT.Register(0, Graph, Moniker, ID);
  822.     Moniker := nil;
  823.   end;
  824.  
  825.   //----------------------------------------------------------------------------
  826.   // Disable Graphedit to connect with your filter graph
  827.   //----------------------------------------------------------------------------
  828.   function RemoveGraphFromRot(ID: integer): HRESULT;
  829.   var ROT: IRunningObjectTable;
  830.   begin
  831.     result := GetRunningObjectTable(0, ROT);
  832.     if (result <> S_OK) then exit;
  833.     result := ROT.Revoke(ID);
  834.     ROT := nil;
  835.   end;
  836.  
  837.   function IntToTimeCode(x : longint): TDVDTimeCode;
  838.   begin
  839.     Result.Hours1        := (x and $F0000000) shr 28;
  840.     Result.Hours10       := (x and $0F000000) shr 24;
  841.     Result.Minutes1      := (x and $00F00000) shr 20;
  842.     Result.Minutes10     := (x and $000F0000) shr 16;
  843.     Result.Seconds1      := (x and $0000F000) shr 12;
  844.     Result.Seconds10     := (x and $00000F00) shr 08;
  845.     Result.Frames1       := (x and $000000F0) shr 04;
  846.     Result.Frames10      := (x and $0000000C) shr 02;
  847.     Result.FrameRateCode := (x and $00000003) shr 00;
  848.   end;
  849.  
  850.   function  GetEventCodeDef(code: longint): string;
  851.   begin
  852.     case code of
  853.       EC_ACTIVATE                  : result:= 'EC_ACTIVATE - A video window is being activated or deactivated.';
  854.       EC_BUFFERING_DATA            : result:= 'EC_BUFFERING_DATA - The graph is buffering data, or has stopped buffering data.';
  855.       EC_CLOCK_CHANGED             : result:= 'EC_CLOCK_CHANGED - The reference clock has changed.';
  856.       EC_COMPLETE                  : result:= 'EC_COMPLETE - All data from a particular stream has been rendered.';
  857.       EC_DEVICE_LOST               : result:= 'EC_DEVICE_LOST - A Plug and Play device was removed or has become available again.';
  858.       EC_DISPLAY_CHANGED           : result:= 'EC_DISPLAY_CHANGED - The display mode has changed.';
  859.       EC_END_OF_SEGMENT            : result:= 'EC_END_OF_SEGMENT - The end of a segment has been reached.';
  860.       EC_ERROR_STILLPLAYING        : result:= 'EC_ERROR_STILLPLAYING - An asynchronous command to run the graph has failed.';
  861.       EC_ERRORABORT                : result:= 'EC_ERRORABORT - An operation was aborted because of an error.';
  862.       EC_FULLSCREEN_LOST           : result:= 'EC_FULLSCREEN_LOST - The video renderer is switching out of full-screen mode.';
  863.       EC_GRAPH_CHANGED             : result:= 'EC_GRAPH_CHANGED - The filter graph has changed.';
  864.       EC_NEED_RESTART              : result:= 'EC_NEED_RESTART - A filter is requesting that the graph be restarted.';
  865.       EC_NOTIFY_WINDOW             : result:= 'EC_NOTIFY_WINDOW - Notifies a filter of the video renderer''s window.';
  866.       EC_OLE_EVENT                 : result:= 'EC_OLE_EVENT - A filter is passing a text string to the application.';
  867.       EC_OPENING_FILE              : result:= 'EC_OPENING_FILE - The graph is opening a file, or has finished opening a file.';
  868.       EC_PALETTE_CHANGED           : result:= 'EC_PALETTE_CHANGED - The video palette has changed.';
  869.       EC_PAUSED                    : result:= 'EC_PAUSED - A pause request has completed.';
  870.       EC_QUALITY_CHANGE            : result:= 'EC_QUALITY_CHANGE - The graph is dropping samples, for quality control.';
  871.       EC_REPAINT                   : result:= 'EC_REPAINT - A video renderer requires a repaint.';
  872.       EC_SEGMENT_STARTED           : result:= 'EC_SEGMENT_STARTED - A new segment has started.';
  873.       EC_SHUTTING_DOWN             : result:= 'EC_SHUTTING_DOWN - The filter graph is shutting down, prior to being destroyed.';
  874.       EC_SNDDEV_IN_ERROR           : result:= 'EC_SNDDEV_IN_ERROR - An audio device error has occurred on an input pin.';
  875.       EC_SNDDEV_OUT_ERROR          : result:= 'EC_SNDDEV_OUT_ERROR - An audio device error has occurred on an output pin.';
  876.       EC_STARVATION                : result:= 'EC_STARVATION - A filter is not receiving enough data.';
  877.       EC_STEP_COMPLETE             : result:= 'EC_STEP_COMPLETE - A filter performing frame stepping has stepped the specified number of frames.';
  878.       EC_STREAM_CONTROL_STARTED    : result:= 'EC_STREAM_CONTROL_STARTED - A stream-control start command has taken effect.';
  879.       EC_STREAM_CONTROL_STOPPED    : result:= 'EC_STREAM_CONTROL_STOPPED - A stream-control start command has taken effect.';
  880.       EC_STREAM_ERROR_STILLPLAYING : result:= 'EC_STREAM_ERROR_STILLPLAYING - An error has occurred in a stream. The stream is still playing.';
  881.       EC_STREAM_ERROR_STOPPED      : result:= 'EC_STREAM_ERROR_STOPPED - A stream has stopped because of an error.';
  882.       EC_USERABORT                 : result:= 'EC_USERABORT - The user has terminated playback.';
  883.       EC_VIDEO_SIZE_CHANGED        : result:= 'EC_VIDEO_SIZE_CHANGED - The native video size has changed.';
  884.       EC_WINDOW_DESTROYED          : result:= 'EC_WINDOW_DESTROYED - The video renderer was destroyed or removed from the graph.';
  885.       EC_TIMECODE_AVAILABLE        : result:= 'EC_TIMECODE_AVAILABLE- Sent by filter supporting timecode.';
  886.       EC_EXTDEVICE_MODE_CHANGE     : result:= 'EC_EXTDEVICE_MODE_CHANGE - Sent by filter supporting IAMExtDevice.';
  887.       EC_CLOCK_UNSET               : result:= 'EC_CLOCK_UNSET - notify the filter graph to unset the current graph clock.';
  888.       EC_TIME                      : result:= 'EC_TIME - The requested reference time occurred (currently not used).';
  889.       EC_VMR_RENDERDEVICE_SET      : result:= 'EC_VMR_RENDERDEVICE_SET - Identifies the type of rendering mechanism the VMR is using to display video.';
  890.  
  891.       EC_DVD_ANGLE_CHANGE              : result:= 'EC_DVD_ANGLE_CHANGE - Signals that either the number of available angles changed or that the current angle number changed.';
  892.       EC_DVD_ANGLES_AVAILABLE          : result:= 'EC_DVD_ANGLES_AVAILABLE - Indicates whether an angle block is being played and angle changes can be performed.';
  893.       EC_DVD_AUDIO_STREAM_CHANGE       : result:= 'EC_DVD_AUDIO_STREAM_CHANGE - Signals that the current audio stream number changed for the main title.';
  894.       EC_DVD_BUTTON_AUTO_ACTIVATED     : result:= 'EC_DVD_BUTTON_AUTO_ACTIVATED - Signals that a menu button has been automatically activated per instructions on the disc.';
  895.       EC_DVD_BUTTON_CHANGE             : result:= 'EC_DVD_BUTTON_CHANGE - Signals that either the number of available buttons changed or that the currently selected button number changed.';
  896.       EC_DVD_CHAPTER_AUTOSTOP          : result:= 'EC_DVD_CHAPTER_AUTOSTOP - Indicates that playback stopped as the result of a call to the IDvdControl2::PlayChaptersAutoStop method.';
  897.       EC_DVD_CHAPTER_START             : result:= 'EC_DVD_CHAPTER_START - Signals that the DVD Navigator started playback of a new chapter in the current title.';
  898.       EC_DVD_CMD_START                 : result:= 'EC_DVD_CMD_START - Signals that a particular command has begun.';
  899.       EC_DVD_CMD_END                   : result:= 'EC_DVD_CMD_END - Signals that a particular command has completed.';
  900.       EC_DVD_CURRENT_HMSF_TIME         : result:= 'EC_DVD_CURRENT_HMSF_TIME - Signals the current time in DVD_HMSF_TIMECODE format at the beginning of every VOBU, which occurs every .4 to 1.0 sec.';
  901.       EC_DVD_CURRENT_TIME              : result:= 'EC_DVD_CURRENT_TIME - Signals the beginning of every video object unit (VOBU), a video segment which is 0.4 to 1.0 seconds in length.';
  902.       EC_DVD_DISC_EJECTED              : result:= 'EC_DVD_DISC_EJECTED - Signals that a disc has been ejected from the drive.';
  903.       EC_DVD_DISC_INSERTED             : result:= 'EC_DVD_DISC_INSERTED - Signals that a disc has been inserted into the drive.';
  904.       EC_DVD_DOMAIN_CHANGE             : result:= 'EC_DVD_DOMAIN_CHANGE - Indicates the DVD Navigator''s new domain.';
  905.       EC_DVD_ERROR                     : result:= 'EC_DVD_ERROR - Signals a DVD error condition.';
  906.       EC_DVD_KARAOKE_MODE              : result:= 'EC_DVD_KARAOKE_MODE - Indicates that the Navigator has either begun playing or finished playing karaoke data.';
  907.       EC_DVD_NO_FP_PGC                 : result:= 'EC_DVD_NO_FP_PGC - Indicates that the DVD disc does not have a FP_PGC (First Play Program Chain).';
  908.       EC_DVD_PARENTAL_LEVEL_CHANGE     : result:= 'EC_DVD_PARENTAL_LEVEL_CHANGE - Signals that the parental level of the authored content is about to change.';
  909.       EC_DVD_PLAYBACK_RATE_CHANGE      : result:= 'EC_DVD_PLAYBACK_RATE_CHANGE - Indicates that a playback rate change has been initiated and the new rate is in the parameter.';
  910.       EC_DVD_PLAYBACK_STOPPED          : result:= 'EC_DVD_PLAYBACK_STOPPED - Indicates that playback has been stopped. The DVD Navigator has completed playback of the title and did not find any other branching instruction for subsequent playback.';
  911.       EC_DVD_PLAYPERIOD_AUTOSTOP       : result:= 'EC_DVD_PLAYPERIOD_AUTOSTOP - Indicates that the Navigator has finished playing the segment specified in a call to PlayPeriodInTitleAutoStop.';
  912.       EC_DVD_STILL_OFF                 : result:= 'EC_DVD_STILL_OFF - Signals the end of any still.';
  913.       EC_DVD_STILL_ON                  : result:= 'EC_DVD_STILL_ON - Signals the beginning of any still.';
  914.       EC_DVD_SUBPICTURE_STREAM_CHANGE  : result:= 'EC_DVD_SUBPICTURE_STREAM_CHANGE - Signals that the current subpicture stream number changed for the main title.';
  915.       EC_DVD_TITLE_CHANGE              : result:= 'EC_DVD_TITLE_CHANGE - Indicates when the current title number changes.';
  916.       EC_DVD_VALID_UOPS_CHANGE         : result:= 'EC_DVD_VALID_UOPS_CHANGE - Signals that the available set of IDVDControl2 interface methods has changed.';
  917.       EC_DVD_WARNING                   : result:= 'EC_DVD_WARNING - Signals a DVD warning condition.'
  918.     else
  919.       result := format('Unknow Graph Event ($%x)',[code]);
  920.     end;
  921.   end;
  922.  
  923.   // general purpose function to delete a heap allocated AM_MEDIA_TYPE structure
  924.   // which is useful when calling IEnumMediaTypes::Next as the interface
  925.   // implementation allocates the structures which you must later delete
  926.   // the format block may also be a pointer to an interface to release
  927.   procedure DeleteMediaType(pmt: PAMMediaType);
  928.   begin
  929.     // allow nil pointers for coding simplicity
  930.     if (pmt = nil) then exit;
  931.     FreeMediaType(pmt);
  932.     CoTaskMemFree(pmt);
  933.   end;
  934.  
  935.   // this also comes in useful when using the IEnumMediaTypes interface so
  936.   // that you can copy a media type, you can do nearly the same by creating
  937.   // a CMediaType object but as soon as it goes out of scope the destructor
  938.   // will delete the memory it allocated (this takes a copy of the memory)
  939.   function  CreateMediaType(pSrc: PAMMediaType): PAMMediaType;
  940.   var pMediaType: PAMMediaType;
  941.   begin
  942.     ASSERT(pSrc<>nil);
  943.  
  944.     // Allocate a block of memory for the media type
  945.     pMediaType := CoTaskMemAlloc(sizeof(TAMMediaType));
  946.     if (pMediaType = nil) then
  947.     begin
  948.       result := nil;
  949.       exit;
  950.     end;
  951.  
  952.     // Copy the variable length format block
  953.     CopyMediaType(pMediaType,pSrc);
  954.     result := pMediaType;
  955.   end;
  956.  
  957.   //----------------------------------------------------------------------------
  958.   // Copies a task-allocated AM_MEDIA_TYPE structure.
  959.   //----------------------------------------------------------------------------
  960.   procedure CopyMediaType(pmtTarget: PAMMediaType; pmtSource: PAMMediaType);
  961.   begin
  962.     //  We'll leak if we copy onto one that already exists - there's one
  963.     //  case we can check like that - copying to itself.
  964.     ASSERT(pmtSource <> pmtTarget);
  965.     //pmtTarget^ := pmtSource^;
  966.     move(pmtSource^, pmtTarget^, SizeOf(TAMMediaType));
  967.     if (pmtSource.cbFormat <> 0) then
  968.     begin
  969.       ASSERT(pmtSource.pbFormat <> nil);
  970.       pmtTarget.pbFormat := CoTaskMemAlloc(pmtSource.cbFormat);
  971.       if (pmtTarget.pbFormat = nil) then
  972.         pmtTarget.cbFormat := 0
  973.       else
  974.         CopyMemory(pmtTarget.pbFormat, pmtSource.pbFormat, pmtTarget.cbFormat);
  975.     end;
  976.     if (pmtTarget.pUnk <> nil) then  pmtTarget.pUnk._AddRef;
  977.   end;
  978.  
  979.   procedure FreeMediaType(mt: PAMMediaType);
  980.   begin
  981.     if (mt^.cbFormat <> 0) then
  982.     begin
  983.       CoTaskMemFree(mt^.pbFormat);
  984.       // Strictly unnecessary but tidier
  985.       mt^.cbFormat := 0;
  986.       mt^.pbFormat := nil;
  987.     end;
  988.     if (mt^.pUnk <> nil) then mt^.pUnk := nil;
  989.   end;
  990.  
  991.   //----------------------------------------------------------------------------
  992.   //  Initializes a media type structure given a wave format structure.
  993.   //----------------------------------------------------------------------------
  994.   function CreateAudioMediaType(pwfx: PWaveFormatEx; pmt: PAMMediaType; bSetFormat: boolean): HRESULT;
  995.   begin
  996.     pmt.majortype := MEDIATYPE_Audio;
  997.     if (pwfx.wFormatTag = WAVE_FORMAT_EXTENSIBLE) then
  998.       pmt.subtype := PWAVEFORMATEXTENSIBLE(pwfx).SubFormat
  999.     else
  1000.       pmt.subtype := FOURCCMap(pwfx.wFormatTag);
  1001.     pmt.formattype           := FORMAT_WaveFormatEx;
  1002.     pmt.bFixedSizeSamples    := TRUE;
  1003.     pmt.bTemporalCompression := FALSE;
  1004.     pmt.lSampleSize          := pwfx.nBlockAlign;
  1005.     pmt.pUnk                 := nil;
  1006.     if (bSetFormat) then
  1007.     begin
  1008.       if (pwfx.wFormatTag = WAVE_FORMAT_PCM) then
  1009.         pmt.cbFormat := sizeof(TWAVEFORMATEX)
  1010.       else
  1011.         pmt.cbFormat := sizeof(TWAVEFORMATEX) + pwfx.cbSize;
  1012.       pmt.pbFormat := CoTaskMemAlloc(pmt.cbFormat);
  1013.       if (pmt.pbFormat = nil) then
  1014.       begin
  1015.         result := E_OUTOFMEMORY;
  1016.         exit;
  1017.       end;
  1018.       if (pwfx.wFormatTag = WAVE_FORMAT_PCM) then
  1019.       begin
  1020.         CopyMemory(pmt.pbFormat, pwfx, sizeof(PCMWAVEFORMAT));
  1021.         PWAVEFORMATEX(pmt.pbFormat).cbSize := 0;
  1022.       end
  1023.       else
  1024.       begin
  1025.         CopyMemory(pmt.pbFormat, pwfx, pmt.cbFormat);
  1026.       end;
  1027.     end;
  1028.     result := S_OK;
  1029.   end;
  1030.  
  1031.   function  FOURCCMap(Fourcc: Cardinal): TGUID;
  1032.   const tmpguid : TGUID = '{00000000-0000-0010-8000-00AA00389B71}';
  1033.   begin
  1034.     result := tmpguid;
  1035.     result.D1 := Fourcc;
  1036.   end;
  1037.  
  1038.   { Convert a FCC (Four Char Codes) to Cardinal. A FCC identifie a media type.}
  1039.   {$NODEFINE FCC}
  1040.   function FCC(str: String): Cardinal;
  1041.   begin
  1042.     Assert(Length(str) >= 4);
  1043.     result := PDWORD(str)^;
  1044.   end;
  1045.  
  1046.   function GetFOURCC(Fourcc: Cardinal): string;
  1047.   type TFOURCC= array[0..3] of char;
  1048.   var  CC: TFOURCC;
  1049.   begin
  1050.     case Fourcc of
  1051.       0 : result := 'RGB';
  1052.       1 : result := 'RLE8';
  1053.       2 : result := 'RLE4';
  1054.       3 : result := 'BITFIELDS';   
  1055.     else
  1056.       PDWORD(@CC)^ := Fourcc; // abracadabra
  1057.       result := CC;
  1058.     end;
  1059.   end;
  1060.  
  1061.   {$NODEFINE MAKEFOURCC}
  1062.   function MAKEFOURCC(ch0, ch1, ch2, ch3: char): Cardinal;
  1063.   begin
  1064.     result := Cardinal(BYTE(ch0)) or
  1065.     (Cardinal(BYTE(ch1)) shl 8)   or
  1066.     (Cardinal(BYTE(ch2)) shl 16)  or
  1067.     (Cardinal(BYTE(ch3)) shl 24)
  1068.   end;
  1069.  
  1070.   function GetErrorString(hr: HRESULT): string;
  1071.   var buffer: array[0..254] of char;
  1072.   begin
  1073.     AMGetErrorText(hr,@buffer,255);
  1074.     result := buffer;
  1075.   end;
  1076.  
  1077.   function GetMediaTypeDescription(MediaType: TAMMediaType): string;
  1078.   begin
  1079.     // major types
  1080.     result := 'Major Type: ';
  1081.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_AnalogAudio)   then result := result+'AnalogAudio'   else
  1082.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_AnalogVideo)   then result := result+'Analogvideo'   else
  1083.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_Audio)         then result := result+'Audio'         else
  1084.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_AUXLine21Data) then result := result+'AUXLine21Data' else
  1085.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_File)          then result := result+'File'          else
  1086.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_Interleaved)   then result := result+'Interleaved'   else
  1087.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_LMRT)          then result := result+'LMRT'          else
  1088.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_Midi)          then result := result+'Midi'          else
  1089.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_MPEG2_PES)     then result := result+'MPEG2_PES'     else
  1090.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_ScriptCommand) then result := result+'ScriptCommand' else
  1091.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_Stream)        then result := result+'Stream'        else
  1092.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_Text)          then result := result+'Text'          else
  1093.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_Timecode)      then result := result+'Timecode'      else
  1094.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_URL_STREAM)    then result := result+'URL_STREAM'    else
  1095.     if IsEqualGUID(MediaType.majortype,MEDIATYPE_Video)         then result := result+'Video'         else
  1096.        result := result+'UnKnown ';
  1097.     // sub types
  1098.     result := result + ' - Sub Type: ';
  1099.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_CLPL) then result := result+'CLPL' else
  1100.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_YUYV) then result := result+'YUYV' else
  1101.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_IYUV) then result := result+'IYUV' else
  1102.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_YVU9) then result := result+'YVU9' else
  1103.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Y411) then result := result+'Y411' else
  1104.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Y41P) then result := result+'Y41P' else
  1105.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_YUY2) then result := result+'YUY2' else
  1106.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_YVYU) then result := result+'YVYU' else
  1107.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_UYVY) then result := result+'UYVY' else
  1108.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Y211) then result := result+'Y211' else
  1109.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_YV12) then result := result+'YV12' else
  1110.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_CLJR) then result := result+'CLJR' else
  1111.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_IF09) then result := result+'IF09' else
  1112.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_CPLA) then result := result+'CPLA' else
  1113.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MJPG) then result := result+'MJPG' else
  1114.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_TVMJ) then result := result+'TVMJ' else
  1115.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_WAKE) then result := result+'WAKE' else
  1116.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_CFCC) then result := result+'CFCC' else
  1117.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_IJPG) then result := result+'IJPG' else
  1118.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Plum) then result := result+'Plum' else
  1119.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DVCS) then result := result+'DVCS' else
  1120.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DVSD) then result := result+'DVSD' else
  1121.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MDVF) then result := result+'MDVF' else
  1122.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RGB1) then result := result+'RGB1' else
  1123.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RGB4) then result := result+'RGB4' else
  1124.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RGB8) then result := result+'RGB8' else
  1125.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RGB565) then result := result+'RGB565' else
  1126.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RGB555) then result := result+'RGB555' else
  1127.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RGB24) then result := result+'RGB24' else
  1128.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RGB32) then result := result+'RGB32' else
  1129.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_ARGB32) then result := result+'ARGB32' else
  1130.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Overlay) then result := result+'Overlay' else
  1131.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG1Packet) then result := result+'MPEG1Packet' else
  1132.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG1Payload) then result := result+'MPEG1Payload' else
  1133.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG1AudioPayload) then result := result+'MPEG1AudioPayload' else
  1134.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG1System) then result := result+'MPEG1System' else
  1135.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG1VideoCD) then result := result+'MPEG1VideoCD' else
  1136.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG1Video) then result := result+'MPEG1Video' else
  1137.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG1Audio) then result := result+'MPEG1Audio' else
  1138.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Avi) then result := result+'Avi' else
  1139.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Asf) then result := result+'Asf' else
  1140.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_QTMovie) then result := result+'QTMovie' else
  1141.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_QTRpza) then result := result+'QTRpza' else
  1142.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_QTSmc) then result := result+'QTSmc' else
  1143.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_QTRle) then result := result+'QTRle' else
  1144.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_QTJpeg) then result := result+'QTJpeg' else
  1145.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_PCMAudio_Obsolete) then result := result+'PCMAudio_Obsolete' else
  1146.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_PCM) then result := result+'PCM' else
  1147.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_WAVE) then result := result+'WAVE' else
  1148.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AU) then result := result+'AU' else
  1149.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AIFF) then result := result+'AIFF' else
  1150.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_dvsd_) then result := result+'dvsd_' else
  1151.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_dvhd) then result := result+'dvhd' else
  1152.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_dvsl) then result := result+'dvsl' else
  1153.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Line21_BytePair) then result := result+'Line21_BytePair' else
  1154.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Line21_GOPPacket) then result := result+'Line21_GOPPacket' else
  1155.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_Line21_VBIRawData) then result := result+'Line21_VBIRawData' else
  1156.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DRM_Audio) then result := result+'DRM_Audio' else
  1157.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_IEEE_FLOAT) then result := result+'IEEE_FLOAT' else
  1158.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DOLBY_AC3_SPDIF) then result := result+'DOLBY_AC3_SPDIF' else
  1159.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_RAW_SPORT) then result := result+'RAW_SPORT' else
  1160.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_SPDIF_TAG_241h) then result := result+'SPDIF_TAG_241h' else
  1161.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DssVideo) then result := result+'DssVideo' else
  1162.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DssAudio) then result := result+'DssAudio' else
  1163.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_VPVideo) then result := result+'VPVideo' else
  1164.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_VPVBI) then result := result+'VPVBI' else
  1165.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_NTSC_M) then result := result+'AnalogVideo_NTSC_M' else
  1166.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_B) then result := result+'AnalogVideo_PAL_B' else
  1167.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_D) then result := result+'AnalogVideo_PAL_D' else
  1168.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_G) then result := result+'AnalogVideo_PAL_G' else
  1169.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_H) then result := result+'AnalogVideo_PAL_H' else
  1170.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_I) then result := result+'AnalogVideo_PAL_I' else
  1171.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_M) then result := result+'AnalogVideo_PAL_M' else
  1172.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_N) then result := result+'AnalogVideo_PAL_N' else
  1173.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_PAL_N_COMBO) then result := result+'AnalogVideo_PAL_N_COMBO' else
  1174.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_SECAM_B) then result := result+'AnalogVideo_SECAM_B' else
  1175.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_SECAM_D) then result := result+'AnalogVideo_SECAM_D' else
  1176.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_SECAM_G) then result := result+'AnalogVideo_SECAM_G' else
  1177.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_SECAM_H) then result := result+'AnalogVideo_SECAM_H' else
  1178.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_SECAM_K) then result := result+'AnalogVideo_SECAM_K' else
  1179.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_SECAM_K1) then result := result+'AnalogVideo_SECAM_K1' else
  1180.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_AnalogVideo_SECAM_L) then result := result+'AnalogVideo_SECAM_L' else
  1181.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG2_VIDEO) then result := result+'MPEG2_VIDEO' else
  1182.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG2_PROGRAM) then result := result+'MPEG2_PROGRAM' else
  1183.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG2_TRANSPORT) then result := result+'MPEG2_TRANSPORT' else
  1184.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MPEG2_AUDIO) then result := result+'MPEG2_AUDIO' else
  1185.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DOLBY_AC3) then result := result+'DOLBY_AC3' else
  1186.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DVD_SUBPICTURE) then result := result+'DVD_SUBPICTURE' else
  1187.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DVD_LPCM_AUDIO) then result := result+'DVD_LPCM_AUDIO' else
  1188.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DTS) then result := result+'DTS' else
  1189.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_SDDS) then result := result+'SDDS' else
  1190.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DVD_NAVIGATION_PCI) then result := result+'PCI' else
  1191.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DVD_NAVIGATION_DSI) then result := result+'DSI' else
  1192.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DVD_NAVIGATION_PROVIDER) then result := result+'PROVIDER' else
  1193.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_MP42) then result := result+'MS-MPEG4' else
  1194.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_DIVX) then result := result+'DIVX' else
  1195.     if IsEqualGUID(MediaType.subtype,MEDIASUBTYPE_VOXWARE) then result := result+'VOXWARE_MetaSound' else
  1196.        result := result+'UnKnown ';
  1197.  
  1198.   // format
  1199.     result := result+ ' Format: ';
  1200.     if IsEqualGUID(MediaType.formattype,FORMAT_VideoInfo) then
  1201.     begin
  1202.       result := result+'VideoInfo ';
  1203.       if ((MediaType.cbFormat > 0) and assigned(MediaType.pbFormat)) then
  1204.       with PVideoInfoHeader(MediaType.pbFormat)^.bmiHeader do
  1205.       result := result + format('%s %dX%d, %d bits',
  1206.         [GetFOURCC(biCompression), biWidth, biHeight, biBitCount]);
  1207.     end
  1208.     else
  1209.     begin
  1210.       if IsEqualGUID(MediaType.formattype,FORMAT_VideoInfo2) then
  1211.       begin
  1212.         result := result+'VideoInfo2 ';
  1213.         if ((MediaType.cbFormat > 0) and assigned(MediaType.pbFormat)) then
  1214.         with PVideoInfoHeader2(MediaType.pbFormat)^.bmiHeader do
  1215.         result := result + format('%s %dX%d, %d bits',
  1216.           [GetFOURCC(biCompression), biWidth, biHeight, biBitCount]);
  1217.       end
  1218.       else
  1219.       begin
  1220.         if IsEqualGUID(MediaType.formattype,FORMAT_WaveFormatEx) then
  1221.         begin
  1222.           result := result+'WaveFormatEx: ';
  1223.           if ((MediaType.cbFormat > 0) and assigned(MediaType.pbFormat)) then
  1224.           begin
  1225.             case PWaveFormatEx(MediaType.pbFormat)^.wFormatTag of
  1226.               $0001: result := result+'PCM';  // common
  1227.               $0002: result := result+'ADPCM';
  1228.               $0003: result := result+'IEEE_FLOAT';
  1229.               $0005: result := result+'IBM_CVSD';
  1230.               $0006: result := result+'ALAW';
  1231.               $0007: result := result+'MULAW';
  1232.               $0010: result := result+'OKI_ADPCM';
  1233.               $0011: result := result+'DVI_ADPCM';
  1234.               $0012: result := result+'MEDIASPACE_ADPCM';
  1235.               $0013: result := result+'SIERRA_ADPCM';
  1236.               $0014: result := result+'G723_ADPCM';
  1237.               $0015: result := result+'DIGISTD';
  1238.               $0016: result := result+'DIGIFIX';
  1239.               $0017: result := result+'DIALOGIC_OKI_ADPCM';
  1240.               $0018: result := result+'MEDIAVISION_ADPCM';
  1241.               $0020: result := result+'YAMAHA_ADPCM';
  1242.               $0021: result := result+'SONARC';
  1243.               $0022: result := result+'DSPGROUP_TRUESPEECH';
  1244.               $0023: result := result+'ECHOSC1';
  1245.               $0024: result := result+'AUDIOFILE_AF36';
  1246.               $0025: result := result+'APTX';
  1247.               $0026: result := result+'AUDIOFILE_AF10';
  1248.               $0030: result := result+'DOLBY_AC2';
  1249.               $0031: result := result+'GSM610';
  1250.               $0032: result := result+'MSNAUDIO';
  1251.               $0033: result := result+'ANTEX_ADPCME';
  1252.               $0034: result := result+'CONTROL_RES_VQLPC';
  1253.               $0035: result := result+'DIGIREAL';
  1254.               $0036: result := result+'DIGIADPCM';
  1255.               $0037: result := result+'CONTROL_RES_CR10';
  1256.               $0038: result := result+'NMS_VBXADPCM';
  1257.               $0039: result := result+'CS_IMAADPCM';
  1258.               $003A: result := result+'ECHOSC3';
  1259.               $003B: result := result+'ROCKWELL_ADPCM';
  1260.               $003C: result := result+'ROCKWELL_DIGITALK';
  1261.               $003D: result := result+'XEBEC';
  1262.               $0040: result := result+'G721_ADPCM';
  1263.               $0041: result := result+'G728_CELP';
  1264.               $0050: result := result+'MPEG';
  1265.               $0055: result := result+'MPEGLAYER3';
  1266.               $0060: result := result+'CIRRUS';
  1267.               $0061: result := result+'ESPCM';
  1268.               $0062: result := result+'VOXWARE';
  1269.               $0063: result := result+'CANOPUS_ATRAC';
  1270.               $0064: result := result+'G726_ADPCM';
  1271.               $0065: result := result+'G722_ADPCM';
  1272.               $0066: result := result+'DSAT';
  1273.               $0067: result := result+'DSAT_DISPLAY';
  1274.               $0075: result := result+'VOXWARE'; // aditionnal  ???
  1275.               $0080: result := result+'SOFTSOUND';
  1276.               $0100: result := result+'RHETOREX_ADPCM';
  1277.               $0200: result := result+'CREATIVE_ADPCM';
  1278.               $0202: result := result+'CREATIVE_FASTSPEECH8';
  1279.               $0203: result := result+'CREATIVE_FASTSPEECH10';
  1280.               $0220: result := result+'QUARTERDECK';
  1281.               $0300: result := result+'FM_TOWNS_SND';
  1282.               $0400: result := result+'BTV_DIGITAL';
  1283.               $1000: result := result+'OLIGSM';
  1284.               $1001: result := result+'OLIADPCM';
  1285.               $1002: result := result+'OLICELP';
  1286.               $1003: result := result+'OLISBC';
  1287.               $1004: result := result+'OLIOPR';
  1288.               $1100: result := result+'LH_CODEC';
  1289.               $1400: result := result+'NORRIS';
  1290.             else
  1291.               result := result+'Unknown';
  1292.             end;
  1293.  
  1294.             with PWaveFormatEx(MediaType.pbFormat)^ do
  1295.             result := result + format(', %d Hertz, %d Bits, %d Channels',
  1296.               [nSamplesPerSec, cbSize, nChannels]);
  1297.           end;
  1298.         end
  1299.         else
  1300.         begin
  1301.           if IsEqualGUID(MediaType.formattype,FORMAT_MPEGVideo) then
  1302.           begin
  1303.             result := result+'MPEGVideo ';
  1304.             if ((MediaType.cbFormat > 0) and assigned(MediaType.pbFormat)) then
  1305.             with PMPEG1VIDEOINFO(MediaType.pbFormat)^.hdr.bmiHeader do
  1306.               result := result + format('%s %dX%d, %d bits',
  1307.               [GetFOURCC(biCompression), biWidth, biHeight, biBitCount]);
  1308.  
  1309.           end
  1310.           else
  1311.           begin
  1312.             if IsEqualGUID(MediaType.formattype,FORMAT_MPEG2Video) then
  1313.             begin
  1314.               result := result+'MPEGStreams ';
  1315.               if ((MediaType.cbFormat > 0) and assigned(MediaType.pbFormat)) then
  1316.               with PMPEG2VIDEOINFO(MediaType.pbFormat)^.hdr.bmiHeader do
  1317.                 result := result + format('%s %dX%d, %d bits',
  1318.                 [GetFOURCC(biCompression), biWidth, biHeight, biBitCount]);
  1319.             end
  1320.             else
  1321.             begin  // todo
  1322.               if IsEqualGUID(MediaType.formattype,FORMAT_DvInfo)        then result := result+'DvInfo' else
  1323.               if IsEqualGUID(MediaType.formattype,FORMAT_MPEGStreams)   then result := result+'MPEGStreams' else
  1324.               if IsEqualGUID(MediaType.formattype,FORMAT_DolbyAC3)      then result := result+'DolbyAC3' else
  1325.               if IsEqualGUID(MediaType.formattype,FORMAT_MPEG2Audio)    then result := result+'MPEG2Audio' else
  1326.               if IsEqualGUID(MediaType.formattype,FORMAT_DVD_LPCMAudio) then result := result+'DVD_LPCMAudio' else
  1327.                 result := result+'Unknown';
  1328.             end;
  1329.           end;
  1330.         end;
  1331.       end;
  1332.     end;
  1333.   end;
  1334.  
  1335.   function ShowFilterPropertyPage(parent: THandle; Filter: IBaseFilter;
  1336.     PropertyPage: TPropertyPage = ppDefault): HRESULT;
  1337.   var
  1338.     SpecifyPropertyPages : ISpecifyPropertyPages;
  1339.     CaptureDialog : IAMVfwCaptureDialogs;
  1340.     CompressDialog: IAMVfwCompressDialogs;
  1341.     CAGUID  :TCAGUID;
  1342.     FilterInfo: TFilterInfo;
  1343.     Code: Integer;
  1344.   begin
  1345.     result := S_FALSE;
  1346.     code := 0;
  1347.     if Filter = nil then exit;
  1348.  
  1349.     ZeroMemory(@FilterInfo, SizeOf(TFilterInfo));
  1350.  
  1351.     case PropertyPage of
  1352.       ppVFWCapDisplay: code := VfwCaptureDialog_Display;
  1353.       ppVFWCapFormat : code := VfwCaptureDialog_Format;
  1354.       ppVFWCapSource : code := VfwCaptureDialog_Source;
  1355.       ppVFWCompConfig: code := VfwCompressDialog_Config;
  1356.       ppVFWCompAbout : code := VfwCompressDialog_About;
  1357.     end;
  1358.  
  1359.     case PropertyPage of
  1360.       ppDefault:
  1361.         begin
  1362.           result := Filter.QueryInterface(IID_ISpecifyPropertyPages, SpecifyPropertyPages);
  1363.           if result <> S_OK then exit;
  1364.           result := SpecifyPropertyPages.GetPages(CAGUID);
  1365.           if result <> S_OK then exit;
  1366.           result := Filter.QueryFilterInfo(FilterInfo);
  1367.           if result <> S_OK then exit;
  1368.           result := OleCreatePropertyFrame(parent, 0, 0, FilterInfo.achName, 1, @Filter, CAGUID.cElems, CAGUID.pElems, 0, 0, nil )
  1369.         end;
  1370.       ppVFWCapDisplay..ppVFWCapSource:
  1371.         begin
  1372.           result := Filter.QueryInterface(IID_IAMVfwCaptureDialogs,CaptureDialog);
  1373.           if (result <> S_OK) then exit;
  1374.           result := CaptureDialog.HasDialog(code);
  1375.           if result <> S_OK then exit;
  1376.           result := CaptureDialog.ShowDialog(code,parent);
  1377.         end;
  1378.       ppVFWCompConfig..ppVFWCompAbout:
  1379.         begin
  1380.           result := Filter.QueryInterface(IID_IAMVfwCompressDialogs, CompressDialog);
  1381.           if (result <> S_OK) then exit;
  1382.           case PropertyPage of
  1383.             ppVFWCompConfig: result := CompressDialog.ShowDialog(VfwCompressDialog_QueryConfig, 0);
  1384.             ppVFWCompAbout : result := CompressDialog.ShowDialog(VfwCompressDialog_QueryAbout, 0);
  1385.           end;
  1386.           if result <> S_OK then exit;
  1387.           result := CompressDialog.ShowDialog(code,parent);
  1388.         end;
  1389.     end;
  1390.   end;
  1391.  
  1392.   function HaveFilterPropertyPage(Filter: IBaseFilter;
  1393.     PropertyPage: TPropertyPage = ppDefault): boolean;
  1394.   var
  1395.     SpecifyPropertyPages : ISpecifyPropertyPages;
  1396.     CaptureDialog : IAMVfwCaptureDialogs;
  1397.     CompressDialog: IAMVfwCompressDialogs;
  1398.     Code: Integer;
  1399.     HR: HRESULT;
  1400.   begin
  1401.     result := false;
  1402.     code := 0;
  1403.     if Filter = nil then exit;
  1404.  
  1405.     case PropertyPage of
  1406.       ppVFWCapDisplay: code := VfwCaptureDialog_Display;
  1407.       ppVFWCapFormat : code := VfwCaptureDialog_Format;
  1408.       ppVFWCapSource : code := VfwCaptureDialog_Source;
  1409.       ppVFWCompConfig: code := VfwCompressDialog_QueryConfig;
  1410.       ppVFWCompAbout : code := VfwCompressDialog_QueryAbout;
  1411.     end;
  1412.  
  1413.     case PropertyPage of
  1414.       ppDefault: result := Succeeded(Filter.QueryInterface(IID_ISpecifyPropertyPages, SpecifyPropertyPages));
  1415.       ppVFWCapDisplay..ppVFWCapSource:
  1416.         begin
  1417.           HR := Filter.QueryInterface(IID_IAMVfwCaptureDialogs,CaptureDialog);
  1418.           if (HR <> S_OK) then exit;
  1419.           result := Succeeded(CaptureDialog.HasDialog(code));
  1420.         end;
  1421.       ppVFWCompConfig..ppVFWCompAbout:
  1422.         begin
  1423.           HR := Filter.QueryInterface(IID_IAMVfwCompressDialogs, CompressDialog);
  1424.           if (HR <> S_OK) then exit;
  1425.           result := Succeeded(CompressDialog.ShowDialog(code,0));
  1426.         end;
  1427.     end;
  1428.   end;
  1429.  
  1430.   function ShowPinPropertyPage(parent: THandle; Pin: IPin): HRESULT;
  1431.   var
  1432.     SpecifyPropertyPages: ISpecifyPropertyPages;
  1433.     CAGUID :TCAGUID;
  1434.     PinInfo: TPinInfo;
  1435.   begin
  1436.     result := S_FALSE;
  1437.     if Pin = nil then exit;
  1438.     result := Pin.QueryInterface(IID_ISpecifyPropertyPages, SpecifyPropertyPages);
  1439.     if result <> S_OK then exit;
  1440.     result := SpecifyPropertyPages.GetPages(CAGUID);
  1441.     if result <> S_OK then exit;
  1442.     result := Pin.QueryPinInfo(PinInfo);
  1443.     if result <> S_OK then exit;
  1444.     result := OleCreatePropertyFrame(parent, 0, 0, PinInfo.achName, 1, @Pin, CAGUID.cElems, CAGUID.pElems, 0, 0, nil )
  1445.   end;
  1446.  
  1447.   function RefTimeToMiliSec(RefTime: int64): Cardinal;
  1448.   begin
  1449.     result := Cardinal(RefTime div 10000);
  1450.   end;
  1451.  
  1452.   function MiliSecToRefTime(Milisec: int64): Int64;
  1453.   begin
  1454.     result := Milisec * 10000;
  1455.   end;
  1456.  
  1457. // The mechanism for describing a bitmap format is with the BITMAPINFOHEADER
  1458. // This is really messy to deal with because it invariably has fields that
  1459. // follow it holding bit fields, palettes and the rest. This function gives
  1460. // the number of bytes required to hold a VIDEOINFO that represents it. This
  1461. // count includes the prefix information (like the rcSource rectangle) the
  1462. // BITMAPINFOHEADER field, and any other colour information on the end.
  1463. //
  1464. // WARNING If you want to copy a BITMAPINFOHEADER into a VIDEOINFO always make
  1465. // sure that you use the HEADER macro because the BITMAPINFOHEADER field isn't
  1466. // right at the start of the VIDEOINFO (there are a number of other fields),
  1467. //
  1468. //     CopyMemory(HEADER(pVideoInfo),pbmi,sizeof(BITMAPINFOHEADER));
  1469. //
  1470.  
  1471.   function GetBitmapFormatSize(const Header: TBitmapInfoHeader): Integer;
  1472.   var Size, Entries: Integer;
  1473.   begin
  1474.     // Everyone has this to start with this
  1475.     Size := SIZE_PREHEADER + Header.biSize;
  1476.  
  1477.     ASSERT(Header.biSize >= sizeof(TBitmapInfoHeader));
  1478.     
  1479.     // Does this format use a palette, if the number of colours actually used
  1480.     // is zero then it is set to the maximum that are allowed for that colour
  1481.     // depth (an example is 256 for eight bits). Truecolour formats may also
  1482.     // pass a palette with them in which case the used count is non zero
  1483.  
  1484.     // This would scare me.
  1485.     ASSERT((Header.biBitCount <= iPALETTE) or (Header.biClrUsed = 0));
  1486.  
  1487.     if ((Header.biBitCount <= iPALETTE) or BOOL(Header.biClrUsed)) then
  1488.     begin
  1489.         Entries := DWORD(1) shl Header.biBitCount;
  1490.         if BOOL(Header.biClrUsed) then Entries := Header.biClrUsed;
  1491.         Size := Size + Entries * sizeof(RGBQUAD);
  1492.     end;
  1493.  
  1494.     // Truecolour formats may have a BI_BITFIELDS specifier for compression
  1495.     // type which means that room for three DWORDs should be allocated that
  1496.     // specify where in each pixel the RGB colour components may be found
  1497.  
  1498.     if (Header.biCompression = BI_BITFIELDS) then Size := Size + SIZE_MASKS;
  1499.     result := Size;
  1500.   end;
  1501.  
  1502.  
  1503.   function GetSourceRectFromMediaType(const MediaType: TAMMediaType): TRect;
  1504.     function GetbmiHeader(const MediaType: TAMMediaType): PBitmapInfoHeader;
  1505.     begin
  1506.       result := nil;
  1507.       if MediaType.pbFormat = nil then exit;
  1508.       if (IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo) and
  1509.           (MediaType.cbFormat >= sizeof(TVIDEOINFOHEADER))) then
  1510.         result := @PVIDEOINFOHEADER(MediaType.pbFormat)^.bmiHeader
  1511.       else if (IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo2) and
  1512.                (MediaType.cbFormat >= sizeof(TVIDEOINFOHEADER2))) then
  1513.         result := @PVIDEOINFOHEADER2(MediaType.pbFormat)^.bmiHeader;
  1514.     end;
  1515.   var bih: PBITMAPINFOHEADER;
  1516.   begin
  1517.     ZeroMemory(@Result,SizeOf(TRect));
  1518.     if MediaType.pbFormat = nil then exit;
  1519.     if (IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo) and
  1520.         (MediaType.cbFormat >= sizeof(TVIDEOINFOHEADER))) then
  1521.       result := PVideoInfoHeader(MediaType.pbFormat)^.rcSource
  1522.     else if (IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo2) and
  1523.              (MediaType.cbFormat >= sizeof(TVIDEOINFOHEADER2))) then
  1524.       result := PVIDEOINFOHEADER2(MediaType.pbFormat)^.rcSource;
  1525.     if IsRectEmpty(result) then
  1526.     begin
  1527.       bih := GetbmiHeader(MediaType);
  1528.       if bih <> nil then
  1529.         SetRect(result, 0, 0, abs(bih.biWidth), abs(bih.biHeight));
  1530.     end;
  1531.   end;
  1532.  
  1533.   function StretchRect(R, IR: TRect): TRect;
  1534.   var
  1535.     iW, iH: Integer;
  1536.     rW, rH: Integer;
  1537.   begin
  1538.     iW := IR.Right - IR.Left;
  1539.     iH := IR.Bottom - IR.Top;
  1540.     rW := R.Right - R.Left;
  1541.     rH := R.Bottom - R.Top;
  1542.     if (rW / iW) < (rH / iH) then
  1543.       begin
  1544.         iH := MulDiv(iH, rW, iW);
  1545.         iW := MulDiv(iW, rW, iW);
  1546.       end
  1547.     else
  1548.       begin
  1549.         iW := MulDiv(iW, rH, iH);
  1550.         iH := MulDiv(iH, rH, iH);
  1551.       end;
  1552.     SetRect(Result, 0, 0, iW, iH);
  1553.     OffsetRect(Result, R.Left + (rW - iW) div 2, R.Top + (rH - iH) div 2);
  1554.   end;
  1555.  
  1556.   function CheckDSError(HR: HRESULT): HRESULT;
  1557.   var Excep: EDirectShowException;
  1558.   begin
  1559.     Result := HR;
  1560.     if Failed(HR) then
  1561.     begin
  1562.       Excep := EDirectShowException.Create(format(GetErrorString(HR)+' ($%x).',[HR]));
  1563.       Excep.ErrorCode := HR;
  1564.       raise Excep;
  1565.     end;
  1566.   end;
  1567.  
  1568.  
  1569. // *****************************************************************************
  1570. //  TSysDevEnum
  1571. // *****************************************************************************
  1572.  
  1573.   procedure TSysDevEnum.GetCat(catlist: TList; CatGUID: TGUID);
  1574.   var
  1575.     SysDevEnum : ICreateDevEnum;
  1576.     EnumCat    : IEnumMoniker;
  1577.     Moniker    : IMoniker;
  1578.     Fetched    : ULONG;
  1579.     PropBag    : IPropertyBag;
  1580.     Name       : olevariant;
  1581.     hr         : HRESULT;
  1582.     i          : integer;
  1583.   begin
  1584.     if catList.Count > 0 then
  1585.       for i := 0 to (catList.Count - 1) do if assigned(catList.Items[i]) then Dispose(catList.Items[i]);
  1586.     catList.Clear;
  1587.     CocreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC, IID_ICreateDevEnum, SysDevEnum);
  1588.     hr := SysDevEnum.CreateClassEnumerator(CatGUID, EnumCat, 0);
  1589.     if (hr = S_OK) then
  1590.     begin
  1591.       while(EnumCat.Next(1, Moniker, @Fetched) = S_OK) do
  1592.         begin
  1593.           Moniker.BindToStorage(nil, nil, IID_IPropertyBag, PropBag);
  1594.           new(ACategory);
  1595.           PropBag.Read('FriendlyName', Name, nil);
  1596.           ACategory^.FriendlyName := Name;
  1597.           if (PropBag.Read('CLSID',Name,nil) = S_OK) then
  1598.             ACategory^.CLSID := StringToGUID(Name)
  1599.           else
  1600.             ACategory^.CLSID := GUID_NULL;
  1601.           catlist.Add(ACategory);
  1602.           PropBag := nil;
  1603.           Moniker := nil;
  1604.         end;
  1605.     end;
  1606.     EnumCat :=nil;
  1607.     SysDevEnum :=nil;
  1608.   end;
  1609.  
  1610.   Constructor TSysDevEnum.Create;
  1611.   begin
  1612.     FCategories := TList.Create;
  1613.     FFilters    := TList.Create;
  1614.     getcat(FCategories,CLSID_ActiveMovieCategories);
  1615.   end;
  1616.  
  1617.   constructor TSysDevEnum.create(guid: TGUID);
  1618.   begin
  1619.     FCategories := TList.Create;
  1620.     FFilters    := TList.Create;
  1621.     getcat(FCategories,CLSID_ActiveMovieCategories);
  1622.     SelectGUIDCategory(guid);
  1623.   end;
  1624.  
  1625.   destructor TSysDevEnum.Destroy;
  1626.   var i: integer;
  1627.   begin
  1628.     inherited Destroy;
  1629.     if FCategories.Count > 0 then
  1630.       for i := 0 to (FCategories.Count - 1) do
  1631.         if assigned(FCategories.Items[i]) then Dispose(FCategories.items[i]);
  1632.     FCategories.Clear;
  1633.     FreeAndNil(FCategories);
  1634.     if FFilters.Count > 0 then
  1635.       for i := 0 to (FFilters.Count - 1) do
  1636.         if assigned(FFilters.Items[i]) then Dispose(FFilters.Items[i]);
  1637.     FFilters.Clear;
  1638.     FreeAndNil(FFilters);
  1639.   end;
  1640.  
  1641.   function TSysDevEnum.GetCategory(item: integer): TFilCatNode;
  1642.   var PCategory: PFilCatNode;
  1643.   begin
  1644.     PCategory := FCategories.Items[item];
  1645.     result := PCategory^;
  1646.   end;
  1647.  
  1648.   function TSysDevEnum.GetFilter(item: integer): TFilCatNode;
  1649.   var PCategory: PFilCatNode;
  1650.   begin
  1651.     PCategory := FFilters.Items[item];
  1652.     result := PCategory^;
  1653.   end;
  1654.  
  1655.   function TSysDevEnum.GetCountCategories: integer;
  1656.   begin
  1657.     result := FCategories.Count;
  1658.   end;
  1659.  
  1660.   function TSysDevEnum.GetCountFilters: integer;
  1661.   begin
  1662.     result := FFilters.Count;
  1663.   end;
  1664.  
  1665.   procedure TSysDevEnum.SelectGUIDCategory(GUID: TGUID);
  1666.   begin
  1667.     FGUID := GUID;
  1668.     getcat(FFilters,FGUID);
  1669.   end;
  1670.  
  1671.   procedure TSysDevEnum.SelectIndexCategory(index: integer);
  1672.   begin
  1673.     SelectGUIDCategory(Categories[index].CLSID);
  1674.   end;
  1675.  
  1676.   function TSysDevEnum.GetMoniker(index: integer): IMoniker;
  1677.   var
  1678.     SysDevEnum  : ICreateDevEnum;
  1679.     EnumCat     : IEnumMoniker;
  1680.   begin
  1681.     result := nil;
  1682.    if ((index < CountFilters) and (index >= 0)) then
  1683.       begin
  1684.         CocreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC, IID_ICreateDevEnum, SysDevEnum);
  1685.         SysDevEnum.CreateClassEnumerator(FGUID, EnumCat, 0);
  1686.         EnumCat.Skip(index);
  1687.         EnumCat.Next(1, Result, nil);
  1688.         EnumCat.Reset;
  1689.         SysDevEnum := nil;
  1690.         EnumCat    := nil;
  1691.       end
  1692.   end;
  1693.  
  1694.   function TSysDevEnum.GetBaseFilter(index: integer): IBaseFilter;
  1695.   var
  1696.     SysDevEnum  : ICreateDevEnum;
  1697.     EnumCat     : IEnumMoniker;
  1698.     Moniker     : IMoniker;
  1699.   begin
  1700.     result := nil;
  1701.    if ((index < CountFilters) and (index >= 0)) then
  1702.       begin
  1703.         CocreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC, IID_ICreateDevEnum, SysDevEnum);
  1704.         SysDevEnum.CreateClassEnumerator(FGUID, EnumCat, 0);
  1705.         EnumCat.Skip(index);
  1706.         EnumCat.Next(1, Moniker, nil);
  1707.         Moniker.BindToObject(nil, nil, IID_IBaseFilter, result);
  1708.         EnumCat.Reset;
  1709.         SysDevEnum := nil;
  1710.         EnumCat    := nil;
  1711.         Moniker    := nil;
  1712.       end
  1713.   end;
  1714.  
  1715.   function TSysDevEnum.GetBaseFilter(GUID: TGUID): IBaseFilter;
  1716.   var
  1717.     i: integer;
  1718.   begin
  1719.     result := nil;
  1720.     if countFilters > 0 then
  1721.     for i := 0 to CountFilters - 1 do
  1722.       if IsEqualGUID(GUID,Filters[i].CLSID) then
  1723.       begin
  1724.         result := GetBaseFilter(i);
  1725.         exit;
  1726.       end;
  1727.   end;
  1728.  
  1729. //******************************************************************************
  1730. //
  1731. //  TMediaType implementation
  1732. //
  1733. //******************************************************************************
  1734.  
  1735.   destructor TMediaType.Destroy;
  1736.   begin
  1737.     FreeMediaType(AMMediaType);
  1738.     dispose(AMMediaType);
  1739.     inherited Destroy;
  1740.   end;
  1741.  
  1742.   // copy constructor does a deep copy of the format block
  1743.  
  1744.   constructor TMediaType.Create;
  1745.   begin
  1746.     InitMediaType;
  1747.   end;
  1748.  
  1749.   constructor TMediaType.Create(majortype: TGUID);
  1750.   begin
  1751.     InitMediaType;
  1752.     AMMediaType.majortype := majortype;
  1753.   end;
  1754.  
  1755.   constructor TMediaType.Create(mediatype: PAMMediaType);
  1756.   begin
  1757.     InitMediaType;
  1758.     CopyMediaType(AMMediaType, mediatype);
  1759.   end;
  1760.  
  1761.   constructor TMediaType.Create(MTClass: TMediaType);
  1762.   begin
  1763.     InitMediaType;
  1764.     CopyMediaType(AMMediaType, MTClass.AMMediaType);
  1765.   end;
  1766.  
  1767.   procedure TMediaType.DefineProperties(Filer: TFiler);
  1768.     function DoWrite: Boolean;
  1769.     begin
  1770.       result := true;
  1771.       if Filer.Ancestor <> nil then
  1772.       begin
  1773.         Result := True;
  1774.         if Filer.Ancestor is TMediaType then
  1775.           Result := not Equal(TMediaType(Filer.Ancestor))
  1776.       end;
  1777.     end;
  1778.   begin
  1779.     Filer.DefineBinaryProperty('data', ReadData, WriteData, DoWrite);
  1780.   end;
  1781.  
  1782.   procedure TMediaType.ReadData(Stream: TStream);
  1783.   begin
  1784.     ResetFormatBuffer;
  1785.     Stream.Read(AMMediaType^, SizeOf(TAMMediaType));
  1786.     if FormatLength > 0 then
  1787.     begin
  1788.       AMMediaType.pbFormat := CoTaskMemAlloc(FormatLength);
  1789.       Stream.Read(AMMediaType.pbFormat^, FormatLength)
  1790.     end;
  1791.   end;
  1792.  
  1793.   procedure TMediaType.WriteData(Stream: TStream);
  1794.   begin
  1795.     Stream.Write(AMMediaType^, SizeOf(TAMMediaType));
  1796.     if FormatLength > 0 then
  1797.       Stream.Write(AMMediaType.pbFormat^, FormatLength);
  1798.   end;
  1799.  
  1800.   // copy MTClass.AMMediaType to current AMMediaType
  1801.   procedure TMediaType.Assign(Source: TPersistent);
  1802.   begin
  1803.     if Source is TMediaType then
  1804.     begin
  1805.       if (Source <> self) then
  1806.       begin
  1807.         FreeMediaType(AMMediaType);
  1808.         CopyMediaType(AMMediaType, TMediaType(Source).AMMediaType);
  1809.       end;
  1810.     end
  1811.     else
  1812.       inherited Assign(Source);
  1813.   end;
  1814.  
  1815.   // this class inherits publicly from AM_MEDIA_TYPE so the compiler could generate
  1816.   // the following assignment operator itself, however it could introduce some
  1817.   // memory conflicts and leaks in the process because the structure contains
  1818.   // a dynamically allocated block (pbFormat) which it will not copy correctly
  1819.   procedure TMediaType.Read(mediatype: PAMMediaType);
  1820.   begin
  1821.     if (mediatype <> self.AMMediaType) then
  1822.     begin
  1823.       FreeMediaType(AMMediaType);
  1824.       CopyMediaType(AMMediaType, mediatype);
  1825.     end;
  1826.   end;
  1827.  
  1828.   function TMediaType.Equal(MTClass: TMediaType): boolean;
  1829.   begin
  1830.     // I don't believe we need to check sample size or
  1831.     // temporal compression flags, since I think these must
  1832.     // be represented in the type, subtype and format somehow. They
  1833.     // are pulled out as separate flags so that people who don't understand
  1834.     // the particular format representation can still see them, but
  1835.     // they should duplicate information in the format block.
  1836.     result := ((IsEqualGUID(AMMediaType.majortype,MTClass.AMMediaType.majortype) = TRUE) and
  1837.         (IsEqualGUID(AMMediaType.subtype,MTClass.AMMediaType.subtype) = TRUE) and
  1838.         (IsEqualGUID(AMMediaType.formattype,MTClass.AMMediaType.formattype) = TRUE) and
  1839.         (AMMediaType.cbFormat = MTClass.AMMediaType.cbFormat) and
  1840.         ( (AMMediaType.cbFormat = 0) or
  1841.           (CompareMem(AMMediaType.pbFormat, MTClass.AMMediaType.pbFormat, AMMediaType.cbFormat))));
  1842.   end;
  1843.  
  1844.   // Check to see if they are equal
  1845.   function TMediaType.NotEqual(MTClass: TMediaType): boolean;
  1846.   begin
  1847.     if (self = MTClass) then
  1848.      result := FALSE
  1849.     else
  1850.      result := TRUE;
  1851.   end;
  1852.  
  1853.   // By default, TDSMediaType objects are initialized with a major type of GUID_NULL.
  1854.   // Call this method to determine whether the object has been correctly initialized.
  1855.   function TMediaType.IsValid: boolean;
  1856.   begin
  1857.     result := not IsEqualGUID(AMMediaType.majortype,GUID_NULL);
  1858.   end;
  1859.  
  1860.   // Determines if the samples have a fixed size or a variable size.
  1861.   function TMediaType.IsFixedSize: boolean;
  1862.   begin
  1863.     result := AMMediaType.bFixedSizeSamples;
  1864.   end;
  1865.  
  1866.   // Determines if the stream uses temporal compression.
  1867.   function TMediaType.IsTemporalCompressed: boolean;
  1868.   begin
  1869.     result := AMMediaType.bTemporalCompression;
  1870.   end;
  1871.  
  1872.   // If the sample size is fixed, returns the sample size in bytes. Otherwise,
  1873.   // returns zero.
  1874.   function TMediaType.GetSampleSize: ULONG;
  1875.   begin
  1876.     if IsFixedSize then
  1877.       result := AMMediaType.lSampleSize
  1878.     else
  1879.       result := 0;
  1880.   end;
  1881.  
  1882.   // If value of sz is zero, the media type uses variable sample sizes. Otherwise,
  1883.   // the sample size is fixed at sz bytes.
  1884.   procedure TMediaType.SetSampleSize(SZ: ULONG);
  1885.   begin
  1886.     if (sz = 0) then
  1887.     begin
  1888.       SetVariableSize;
  1889.     end
  1890.     else
  1891.     begin
  1892.       AMMediaType.bFixedSizeSamples := TRUE;
  1893.       AMMediaType.lSampleSize := sz;
  1894.     end;
  1895.   end;
  1896.  
  1897.   // Specifies that samples do not have a fixed size.
  1898.   procedure TMediaType.SetVariableSize;
  1899.   begin
  1900.     AMMediaType.bFixedSizeSamples := FALSE;
  1901.   end;
  1902.  
  1903.   // Specifies whether samples are compressed using temporal compression
  1904.   procedure TMediaType.SetTemporalCompression(bCompressed: boolean);
  1905.   begin
  1906.     AMMediaType.bTemporalCompression := bCompressed;
  1907.   end;
  1908.  
  1909.   // Retrieves a pointer to the format block.
  1910.   function TMediaType.Format: pointer;
  1911.   begin
  1912.     result := AMMediaType.pbFormat;
  1913.   end;
  1914.  
  1915.   //Retrieves the length of the format block.
  1916.   function TMediaType.FormatLength: ULONG;
  1917.   begin
  1918.     result := AMMediaType.cbFormat;
  1919.   end;
  1920.  
  1921.   function TMediaType.SetFormat(pFormat: pointer; length: ULONG): boolean;
  1922.   begin
  1923.     if (nil = AllocFormatBuffer(length)) then
  1924.     begin
  1925.        result := false;
  1926.        exit;
  1927.     end;
  1928.     ASSERT(AMMediatype.pbFormat<>nil);
  1929.     CopyMemory(AMMediatype.pbFormat,pFormat,length);
  1930.     result := true;
  1931.   end;
  1932.  
  1933.   // reset the format buffer
  1934.   procedure TMediaType.ResetFormatBuffer;
  1935.   begin
  1936.     if (AMMediaType.cbFormat <> 0) then
  1937.       CoTaskMemFree(AMMediaType.pbFormat);
  1938.     AMMediaType.cbFormat := 0;
  1939.     AMMediaType.pbFormat := nil;
  1940.   end;
  1941.  
  1942.   // allocate length bytes for the format and return a read/write pointer
  1943.   // If we cannot allocate the new block of memory we return NULL leaving
  1944.   // the original block of memory untouched (as does ReallocFormatBuffer)
  1945.   function TMediaType.AllocFormatBuffer(length: ULONG): pointer;
  1946.   var pNewFormat : pointer;
  1947.   begin
  1948.     ASSERT(length<>0);
  1949.  
  1950.     // do the types have the same buffer size
  1951.     if (AMMediaType.cbFormat = length) then
  1952.     begin
  1953.       result := AMMediaType.pbFormat;
  1954.       exit;
  1955.     end;
  1956.  
  1957.     // allocate the new format buffer
  1958.     pNewFormat := CoTaskMemAlloc(length);
  1959.     if (pNewFormat = nil) then
  1960.     begin
  1961.       if (length <= AMMediaType.cbFormat) then
  1962.       begin
  1963.         result :=  AMMediatype.pbFormat; //reuse the old block anyway.
  1964.         exit;
  1965.       end
  1966.       else
  1967.       begin
  1968.         result := nil;
  1969.         exit;
  1970.       end;
  1971.     end;
  1972.  
  1973.     // delete the old format
  1974.     if (AMMediaType.cbFormat <> 0) then
  1975.     begin
  1976.       ASSERT(AMMediaType.pbFormat<>nil);
  1977.       CoTaskMemFree(AMMediaType.pbFormat);
  1978.     end;
  1979.  
  1980.     AMMediaType.cbFormat := length;
  1981.     AMMediaType.pbFormat := pNewFormat;
  1982.     result := AMMediaType.pbFormat;
  1983.   end;
  1984.  
  1985.   // reallocate length bytes for the format and return a read/write pointer
  1986.   // to it. We keep as much information as we can given the new buffer size
  1987.   // if this fails the original format buffer is left untouched. The caller
  1988.   // is responsible for ensuring the size of memory required is non zero
  1989.   function TMediaType.ReallocFormatBuffer(length: ULONG): pointer;
  1990.   var pNewFormat: pointer;
  1991.   begin
  1992.     ASSERT(length<>0);
  1993.  
  1994.     // do the types have the same buffer size
  1995.     if (AMMediaType.cbFormat = length) then
  1996.     begin
  1997.       result := AMMediaType.pbFormat;
  1998.       exit;
  1999.     end;
  2000.  
  2001.     // allocate the new format buffer
  2002.     pNewFormat := CoTaskMemAlloc(length);
  2003.     if (pNewFormat = nil) then
  2004.     begin
  2005.       if (length <= AMMediaType.cbFormat) then
  2006.       begin
  2007.         result := AMMediaType.pbFormat; //reuse the old block anyway.
  2008.         exit;
  2009.       end
  2010.       else
  2011.       begin
  2012.         result := nil;
  2013.         exit;
  2014.       end;
  2015.     end;
  2016.  
  2017.     // copy any previous format (or part of if new is smaller)
  2018.     // delete the old format and replace with the new one
  2019.     if (AMMediaType.cbFormat <> 0) then
  2020.     begin
  2021.       ASSERT(AMMediaType.pbFormat<>nil);
  2022.       CopyMemory(pNewFormat, AMMediaType.pbFormat, min(length,AMMediaType.cbFormat));
  2023.       CoTaskMemFree(AMMediaType.pbFormat);
  2024.     end;
  2025.  
  2026.     AMMediaType.cbFormat := length;
  2027.     AMMediaType.pbFormat := pNewFormat;
  2028.     result := pNewFormat;
  2029.   end;
  2030.  
  2031.   // initialise a media type structure
  2032.   procedure TMediaType.InitMediaType;
  2033.   begin
  2034.     new(AMMediaType);
  2035.     ZeroMemory(AMMediaType, sizeof(TAMMediaType));
  2036.     AMMediaType.lSampleSize := 1;
  2037.     AMMediaType.bFixedSizeSamples := TRUE;
  2038.   end;
  2039.  
  2040.   //Determines if this media type matches a partially specified media type.
  2041.   function TMediaType.MatchesPartial(ppartial: TMediaType): boolean;
  2042.   begin
  2043.     if (not IsEqualGUID(ppartial.AMMediaType.majortype, GUID_NULL) and
  2044.         not IsEqualGUID(AMMediaType.majortype, ppartial.AMMediaType.majortype)) then
  2045.     begin
  2046.       result := false;
  2047.       exit;
  2048.     end;
  2049.     if (not IsEqualGUID(ppartial.AMMediaType.subtype, GUID_NULL) and
  2050.         not IsEqualGUID(AMMediaType.subtype, ppartial.AMMediaType.subtype)) then
  2051.     begin
  2052.       result := false;
  2053.       exit;
  2054.     end;
  2055.  
  2056.     if not IsEqualGUID(ppartial.AMMediaType.formattype, GUID_NULL) then
  2057.     begin
  2058.       // if the format block is specified then it must match exactly
  2059.       if not IsEqualGUID(AMMediaType.formattype, ppartial.AMMediaType.formattype) then
  2060.       begin
  2061.         result := FALSE;
  2062.         exit;
  2063.       end;
  2064.       if (AMMediaType.cbFormat <> ppartial.AMMediaType.cbFormat) then
  2065.       begin
  2066.         result := FALSE;
  2067.         exit;
  2068.       end;
  2069.         if ((AMMediaType.cbFormat <> 0) and
  2070.             (CompareMem(AMMediaType.pbFormat, ppartial.AMMediaType.pbFormat, AMMediaType.cbFormat) <> false)) then
  2071.         begin
  2072.           result := FALSE;
  2073.           exit;
  2074.         end;
  2075.     end;
  2076.     result := TRUE;
  2077.   end;
  2078.  
  2079.   // a partially specified media type can be passed to IPin::Connect
  2080.   // as a constraint on the media type used in the connection.
  2081.   // the type, subtype or format type can be null.
  2082.   function TMediaType.IsPartiallySpecified: boolean;
  2083.   begin
  2084.     if (IsEqualGUID(AMMediaType.majortype, GUID_NULL) or
  2085.         IsEqualGUID(AMMediaType.formattype, GUID_NULL)) then
  2086.     begin
  2087.       result := TRUE;
  2088.       exit;
  2089.     end
  2090.     else
  2091.     begin
  2092.       result := FALSE;
  2093.       exit;
  2094.     end;
  2095.   end;
  2096.  
  2097.   function TMediaType.GetMajorType: TGUID;
  2098.   begin
  2099.     result := AMMediaType.majortype;
  2100.   end;
  2101.  
  2102.   procedure TMediaType.SetMajorType(MT: TGUID);
  2103.   begin
  2104.     AMMediaType.majortype := MT;
  2105.   end;
  2106.  
  2107.   function TMediaType.GetSubType: TGUID;
  2108.   begin
  2109.     result := AMMediaType.subtype;
  2110.   end;
  2111.  
  2112.   procedure TMediaType.SetSubType(ST: TGUID);
  2113.   begin
  2114.     AMMediaType.subtype := ST;
  2115.   end;
  2116.  
  2117.   // set the type of the media type format block, this type defines what you
  2118.   // will actually find in the format pointer. For example FORMAT_VideoInfo or
  2119.   // FORMAT_WaveFormatEx. In the future this may be an interface pointer to a
  2120.   // property set. Before sending out media types this should be filled in.
  2121.   procedure TMediaType.SetFormatType(const GUID: TGUID);
  2122.   begin
  2123.     AMMediaType.formattype := GUID;
  2124.   end;
  2125.  
  2126.   function TMediaType.GetFormatType: TGUID;
  2127.   begin
  2128.     result := AMMediaType.formattype;
  2129.   end;
  2130.  
  2131. //******************************************************************************
  2132. //
  2133. //  TDSEnumMediaType Implementation
  2134. //
  2135. //******************************************************************************
  2136.  
  2137.   constructor TEnumMediaType.Create;
  2138.   begin
  2139.     FList      := TList.Create;
  2140.   end;
  2141.  
  2142.   constructor TEnumMediaType.Create(Pin: IPin);
  2143.   var EnumMT : IEnumMediaTypes;
  2144.       hr     : HRESULT;
  2145.   begin
  2146.     FList      := TList.Create;
  2147.     assert(pin <> nil,'IPin not assigned');
  2148.     hr := pin.EnumMediaTypes(EnumMT);
  2149.     if (hr <> S_OK) then exit;
  2150.     Create(ENumMT);
  2151.   end;
  2152.  
  2153.   constructor TEnumMediaType.Create(EnumMT: IEnumMediaTypes);
  2154.   var pmt: PAMMediaType;
  2155.   begin
  2156.     if (FList = nil) then FList := TList.Create;
  2157.     assert(EnumMT <> nil,'IEnumMediaType not assigned');
  2158.     while (EnumMT.Next(1,pmt,nil)= S_OK) do
  2159.     begin
  2160.       FList.Add(TMediaType.Create(pmt));
  2161.     end;
  2162.   end;
  2163.  
  2164.   constructor TEnumMediaType.Create(FileName: TFileName);
  2165.   begin
  2166.     FList := TList.Create;
  2167.     Assign(FileName);
  2168.   end;
  2169.  
  2170.   destructor TEnumMediaType.Destroy;
  2171.   begin
  2172.     Clear;
  2173.     FList.Free;
  2174.   end;
  2175.  
  2176.   procedure TEnumMediaType.Assign(Pin: IPin);
  2177.   var EnumMT : IEnumMediaTypes;
  2178.       hr     : HRESULT;
  2179.   begin
  2180.     Clear;
  2181.     assert(pin <> nil,'IPin not assigned');
  2182.     hr := pin.EnumMediaTypes(EnumMT);
  2183.     if (hr <> S_OK) then exit;
  2184.     Assign(ENumMT);
  2185.   end;
  2186.  
  2187.   procedure TEnumMediaType.Assign(EnumMT: IEnumMediaTypes);
  2188.   var pmt: PAMMediaType;
  2189.   begin
  2190.     if (count <> 0) then Clear;
  2191.     assert(EnumMT <> nil,'IEnumMediaType not assigned');
  2192.     while (EnumMT.Next(1,pmt,nil)= S_OK) do
  2193.     begin
  2194.       FList.Add(TMediaType.Create(pmt));
  2195.     end;
  2196.   end;
  2197.  
  2198.   procedure TEnumMediaType.Assign(FileName: TFileName);
  2199.   var
  2200.     MediaDet: IMediaDet;
  2201.     KeyProvider : IServiceProvider;
  2202.     hr: HRESULT;
  2203.     Streams: LongInt;
  2204.     i: longint;
  2205.     MediaType: TAMMediaType;
  2206.   begin
  2207.     Clear;
  2208.     hr := CoCreateInstance(CLSID_MediaDet, nil, CLSCTX_INPROC, IID_IMediaDet, MediaDet);
  2209.     assert(hr = S_OK, 'Media Detector not available');
  2210.     hr := MediaDet.put_Filename(FileName);
  2211.     if hr <> S_OK then
  2212.     begin
  2213.       MediaDet := nil;
  2214.       Exit;
  2215.     end;
  2216.     MediaDet.get_OutputStreams(Streams);
  2217.     if streams > 0 then
  2218.     begin
  2219.       for i := 0 to (streams - 1) do
  2220.       begin
  2221.         MediaDet.put_CurrentStream(i);
  2222.         MediaDet.get_StreamMediaType(MediaType);
  2223.         FList.Add(TMediaType.Create(@MediaType));
  2224.       end;
  2225.     end;
  2226.     KeyProvider := nil;
  2227.     MediaDet := nil;
  2228.   end;
  2229.  
  2230.   function TEnumMediaType.GetItem(Index: Integer): TMediaType;
  2231.   begin
  2232.     result := TMediaType(Flist.Items[index]);
  2233.   end;
  2234.  
  2235.   function TEnumMediaType.GetMediaDescription(Index: Integer): string;
  2236.   begin
  2237.     result := '';
  2238.     if ((index < count) and (index > -1)) then
  2239.       result := GetMediaTypeDescription(TMediaType(Flist.Items[index]).AMMediaType^);
  2240.   end;
  2241.  
  2242.   procedure TEnumMediaType.SetItem(Index: Integer; Item: TMediaType);
  2243.   begin
  2244.     TMediaType(Flist.Items[index]).Assign(item);
  2245.   end;
  2246.  
  2247.   function TEnumMediaType.GetCount: integer;
  2248.   begin
  2249.     assert(FList<>nil,'TDSEnumMediaType not created');
  2250.     if (FList <> nil) then
  2251.       result := FList.Count
  2252.     else
  2253.       result := 0;
  2254.   end;
  2255.  
  2256.   function TEnumMediaType.Add(Item: TMediaType): Integer;
  2257.   begin
  2258.     result := FList.Add(Item);
  2259.   end;
  2260.  
  2261.   procedure TEnumMediaType.Clear;
  2262.   var i: Integer;
  2263.   begin
  2264.     if count <> 0 then
  2265.     for i := 0 to (count -1) do
  2266.     begin
  2267.       if (FList.Items[i]<>nil) then TMediaType(FList.Items[i]).Free;
  2268.     end;
  2269.     FList.Clear;
  2270.   end;
  2271.  
  2272.   procedure TEnumMediaType.Delete(Index: Integer);
  2273.   begin
  2274.     if (FList.Items[index]<>nil) then TMediaType(FList.Items[index]).Free;
  2275.     FList.Delete(index);
  2276.   end;
  2277.  
  2278. // *****************************************************************************
  2279. //  TDSFilterList implementation
  2280. // *****************************************************************************
  2281.  
  2282.   constructor TFilterList.Create(FilterGraph: IFilterGraph);
  2283.   begin
  2284.     inherited Create;
  2285.     Graph := FilterGraph;
  2286.     Update;
  2287.   end;
  2288.  
  2289.   destructor TFilterList.Destroy;
  2290.   begin
  2291.     inherited Destroy;
  2292.   end;
  2293.  
  2294.   procedure TFilterList.Update;
  2295.   var EnumFilters: IEnumFilters;
  2296.       Filter: IBaseFilter;
  2297.   begin
  2298.     if assigned(Graph) then
  2299.     Graph.EnumFilters(EnumFilters);
  2300.     while (EnumFilters.Next(1, Filter, nil) = S_OK) do add(Filter);
  2301.     EnumFilters := nil;
  2302.   end;
  2303.  
  2304.   procedure TFilterList.Assign(FilterGraph: IFilterGraph);
  2305.   begin
  2306.     Clear;
  2307.     Graph := FilterGraph;
  2308.     Update;
  2309.   end;
  2310.  
  2311.   function TFilterList.GetFilter(Index: Integer): IBaseFilter;
  2312.   begin
  2313.     result := get(index) as IBaseFilter;
  2314.   end;
  2315.  
  2316.   procedure TFilterList.PutFilter(Index: Integer; Item: IBaseFilter);
  2317.   begin
  2318.     put(index,Item);
  2319.   end;
  2320.  
  2321.   function TFilterList.First: IBaseFilter;
  2322.   begin
  2323.     result := GetFilter(0);
  2324.   end;
  2325.  
  2326.   function TFilterList.IndexOf(Item: IBaseFilter): Integer;
  2327.   begin
  2328.      result := inherited IndexOf(Item);
  2329.   end;
  2330.  
  2331.   function TFilterList.Add(Item: IBaseFilter): Integer;
  2332.   begin
  2333.     result := inherited Add(Item);
  2334.   end;
  2335.  
  2336.   procedure TFilterList.Insert(Index: Integer; Item: IBaseFilter);
  2337.   begin
  2338.     inherited Insert(index,item);
  2339.   end;
  2340.  
  2341.   function TFilterList.Last: IBaseFilter;
  2342.   begin
  2343.     result := inherited Last as IBaseFilter;
  2344.   end;
  2345.  
  2346.   function TFilterList.Remove(Item: IBaseFilter): Integer;
  2347.   begin
  2348.     result := inherited Remove(Item);
  2349.   end;
  2350.  
  2351.   function TFilterList.GetFilterInfo(index: integer): TFilterInfo;
  2352.   begin
  2353.     if assigned(items[index]) then items[index].QueryFilterInfo(result);
  2354.   end;
  2355.  
  2356. // *****************************************************************************
  2357. //  TPinList
  2358. // *****************************************************************************
  2359.  
  2360.   constructor TPinList.Create(BaseFilter: IBaseFilter);
  2361.   begin
  2362.     inherited Create;
  2363.     Filter := BaseFilter;
  2364.     Update;
  2365.   end;
  2366.  
  2367.   destructor TPinList.Destroy;
  2368.   begin
  2369.     Filter := nil;
  2370.     inherited Destroy;
  2371.   end;
  2372.  
  2373.   procedure TPinList.Update;
  2374.   var
  2375.     EnumPins : IEnumPins;
  2376.     Pin      : IPin;
  2377.   begin
  2378.     clear;
  2379.     if assigned(Filter) then Filter.EnumPins(EnumPins) else exit;
  2380.     while (EnumPins.Next(1, pin, nil) = S_OK) do add(Pin);
  2381.     EnumPins := nil;
  2382.   end;
  2383.  
  2384.   procedure TPinList.Assign(BaseFilter: IBaseFilter);
  2385.   begin
  2386.     Clear;
  2387.     Filter := BaseFilter;
  2388.     if Filter <> nil then Update;
  2389.   end;
  2390.  
  2391.   function TPinList.GetConnected(Index: Integer): boolean;
  2392.   var Pin: IPin;
  2393.   begin
  2394.     Items[Index].ConnectedTo(Pin);
  2395.     Result := (Pin <> nil); 
  2396.   end;
  2397.  
  2398.   function TPinList.GetPin(Index: Integer): IPin;
  2399.   begin
  2400.     result := get(index) as IPin;
  2401.   end;
  2402.  
  2403.   procedure TPinList.PutPin(Index: Integer; Item: IPin);
  2404.   begin
  2405.     put(index,Item);
  2406.   end;
  2407.  
  2408.   function TPinList.First: IPin;
  2409.   begin
  2410.     result := GetPin(0);
  2411.   end;
  2412.  
  2413.   function TPinList.IndexOf(Item: IPin): Integer;
  2414.   begin
  2415.      result := inherited IndexOf(Item);
  2416.   end;
  2417.  
  2418.   function TPinList.Add(Item: IPin): Integer;
  2419.   begin
  2420.     result := inherited Add(Item);
  2421.   end;
  2422.  
  2423.   procedure TPinList.Insert(Index: Integer; Item: IPin);
  2424.   begin
  2425.     inherited Insert(index,item);
  2426.   end;
  2427.  
  2428.   function TPinList.Last: IPin;
  2429.   begin
  2430.     result := inherited Last as IPin;
  2431.   end;
  2432.  
  2433.   function TPinList.Remove(Item: IPin): Integer;
  2434.   begin
  2435.     result := inherited Remove(Item);
  2436.   end;
  2437.  
  2438.   function TPinList.GetPinInfo(index: integer): TPinInfo;
  2439.   begin
  2440.     if assigned(Items[index]) then Items[index].QueryPinInfo(result);
  2441.   end;
  2442.  
  2443. // *****************************************************************************
  2444. //  TPersistentMemory
  2445. // *****************************************************************************
  2446.  
  2447.   constructor TPersistentMemory.Create;
  2448.   begin
  2449.     FData := nil;
  2450.     FDataLength := 0;
  2451.   end;
  2452.  
  2453.   destructor TPersistentMemory.Destroy;
  2454.   begin
  2455.     AllocateMemory(0);
  2456.     inherited destroy;
  2457.   end;
  2458.  
  2459.   procedure TPersistentMemory.AllocateMemory(ALength: Cardinal);
  2460.   begin
  2461.     if (FDataLength > 0) and (FData <> nil) then
  2462.     begin
  2463.       FreeMem(FData, FDataLength);
  2464.       FData := nil;
  2465.       FDataLength := 0;
  2466.     end;
  2467.     if ALength > 0 then
  2468.       begin
  2469.         GetMem(FData, ALength);
  2470.         ZeroMemory(FData, ALength);
  2471.         FDataLength := ALength;
  2472.       end
  2473.   end;
  2474.  
  2475.   procedure TPersistentMemory.ReadData(Stream: TStream);
  2476.   var ALength: Cardinal;
  2477.   begin
  2478.     Stream.Read(ALength, SizeOf(Cardinal));
  2479.     AllocateMemory(ALength);
  2480.     if ALength > 0 then
  2481.       Stream.Read(FData^, ALength);
  2482.   end;
  2483.  
  2484.   procedure TPersistentMemory.WriteData(Stream: TStream);
  2485.   begin
  2486.     Stream.Write(FDataLength, SizeOf(Cardinal));
  2487.     if FDataLength > 0 then
  2488.       Stream.Write(FData^, FDataLength);
  2489.   end;
  2490.  
  2491.   procedure TPersistentMemory.Assign(Source: TPersistent);
  2492.   begin
  2493.     if Source is TPersistentMemory then
  2494.     begin
  2495.       if (Source <> self) then
  2496.       begin
  2497.         AllocateMemory(TPersistentMemory(Source).FDataLength);
  2498.         if FDataLength > 0 then
  2499.           move(TPersistentMemory(Source).FData^, FData^, FDataLength);
  2500.       end;
  2501.     end
  2502.     else
  2503.       inherited Assign(Source);
  2504.   end;
  2505.  
  2506.   procedure TPersistentMemory.AssignTo(Dest: TPersistent);
  2507.   begin
  2508.     Dest.Assign(self);
  2509.   end;
  2510.  
  2511.   function TPersistentMemory.Equal(Memory: TPersistentMemory): boolean;
  2512.   begin
  2513.     result := false;
  2514.     if (Memory.FDataLength > 0) and (Memory.FDataLength = FDataLength) and
  2515.        (Memory.FData <> nil) and (FData <> nil) then
  2516.     result := comparemem(Memory.FData, FData, FDataLength);
  2517.   end;
  2518.  
  2519.   procedure TPersistentMemory.DefineProperties(Filer: TFiler);
  2520.     function DoWrite: Boolean;
  2521.     begin
  2522.       result := true;
  2523.       if Filer.Ancestor <> nil then
  2524.       begin
  2525.         Result := True;
  2526.         if Filer.Ancestor is TPersistentMemory then
  2527.           Result := not Equal(TPersistentMemory(Filer.Ancestor))
  2528.       end;
  2529.     end;
  2530.  
  2531.   begin
  2532.     Filer.DefineBinaryProperty('data', ReadData, WriteData, DoWrite);
  2533.   end;
  2534.  
  2535. // *****************************************************************************
  2536. //  TBaseFilter
  2537. // *****************************************************************************
  2538.  
  2539.   procedure TBaseFilter.SetMoniker(Moniker: IMoniker);
  2540.   var
  2541.     MemStream    : TMemoryStream;
  2542.     AdaStream    : TStreamAdapter;
  2543.   begin
  2544.     if Moniker = nil then
  2545.     begin
  2546.       DataLength := 0;
  2547.       exit;
  2548.     end;
  2549.     MemStream := TMemoryStream.Create;
  2550.     AdaStream := TStreamAdapter.Create(MemStream, soReference);
  2551.     OleSaveToStream(Moniker, AdaStream);
  2552.     DataLength := MemStream.Size;
  2553.     move(MemStream.Memory^, Data^, DataLength);
  2554.     AdaStream.Free;
  2555.     MemStream.Free;
  2556.   end;
  2557.  
  2558.   function TBaseFilter.GetMoniker: IMoniker;
  2559.   var
  2560.     MemStream    : TMemoryStream;
  2561.     AdaStream    : TStreamAdapter;
  2562.   begin
  2563.     if DataLength > 0 then
  2564.       begin
  2565.         MemStream := TMemoryStream.Create;
  2566.         MemStream.SetSize(DataLength);
  2567.         move(Data^, MemStream.Memory^, DataLength);
  2568.         AdaStream := TStreamAdapter.Create(MemStream, soReference);
  2569.         OleLoadFromStream(AdaStream, IMoniker, result);
  2570.         AdaStream.Free;
  2571.         MemStream.Free;
  2572.       end
  2573.     else
  2574.       result := nil;
  2575.   end;
  2576.  
  2577.   function TBaseFilter.CreateFilter: IBaseFilter;
  2578.   var
  2579.     AMoniker     : IMoniker;
  2580.   begin
  2581.     AMoniker := Moniker;
  2582.     if AMoniker <> nil then
  2583.       begin
  2584.         AMoniker.BindToObject(nil, nil, IBaseFilter, result);
  2585.         AMoniker := nil;
  2586.       end
  2587.     else
  2588.       result := nil;
  2589.   end;
  2590.  
  2591.   function TBaseFilter.PropertyBag(Name: WideString): OleVariant;
  2592.   var
  2593.     AMoniker : IMoniker;
  2594.     PropBag  : IPropertyBag;
  2595.   begin
  2596.     AMoniker := Moniker;
  2597.     if AMoniker <> nil then
  2598.       begin
  2599.         AMoniker.BindToStorage(nil, nil, IID_IPropertyBag, PropBag);
  2600.         if PropBag <> nil then PropBag.Read(PWideChar(Name), result, nil);
  2601.         PropBag  := nil;
  2602.         AMoniker := nil;
  2603.       end
  2604.     else
  2605.       result := NULL;
  2606.   end;
  2607.  
  2608. end.
  2609.